[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Remove utils/hpc subdirectory and its contents
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Mar 8 11:29:27 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f3ff7cb1 by David Binder at 2023-03-08T01:24:17-05:00
Remove utils/hpc subdirectory and its contents
- - - - -
cf98e286 by David Binder at 2023-03-08T01:24:17-05:00
Add git submodule for utils/hpc
- - - - -
605fbbb2 by David Binder at 2023-03-08T01:24:18-05:00
Update commit for utils/hpc git submodule
- - - - -
606793d4 by David Binder at 2023-03-08T01:24:18-05:00
Update commit for utils/hpc git submodule
- - - - -
4158722a by Sylvain Henry at 2023-03-08T01:24:58-05:00
linker: fix linking with aligned sections (#23066)
Take section alignment into account instead of assuming 16 bytes (which
is wrong when the section requires 32 bytes, cf #23066).
- - - - -
f9c23813 by Greg Steuck at 2023-03-08T06:28:54-05:00
Change hostSupportsRPaths to report False on OpenBSD
OpenBSD does support -rpath but ghc build process relies on some
related features that don't work there. See ghc/ghc#23011
- - - - -
b1409663 by Alexis King at 2023-03-08T06:28:56-05:00
bytecode: Fix bitmaps for BCOs used to tag tuples and prim call args
fixes #23068
- - - - -
28 changed files:
- .gitmodules
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/StgToByteCode.hs
- hadrian/src/Oracles/Setting.hs
- rts/linker/Elf.c
- + testsuite/tests/bytecode/T23068.hs
- + testsuite/tests/bytecode/T23068.script
- + testsuite/tests/bytecode/T23068.stdout
- + testsuite/tests/bytecode/all.T
- testsuite/tests/rts/linker/Makefile
- + testsuite/tests/rts/linker/T23066.stdout
- + testsuite/tests/rts/linker/T23066_c.c
- testsuite/tests/rts/linker/all.T
- + utils/hpc
- − utils/hpc/HpcCombine.hs
- − utils/hpc/HpcDraft.hs
- − utils/hpc/HpcFlags.hs
- − utils/hpc/HpcLexer.hs
- − utils/hpc/HpcMarkup.hs
- − utils/hpc/HpcOverlay.hs
- − utils/hpc/HpcParser.y
- − utils/hpc/HpcReport.hs
- − utils/hpc/HpcShowTix.hs
- − utils/hpc/HpcUtils.hs
- − utils/hpc/Main.hs
- − utils/hpc/Makefile
- − utils/hpc/hpc-bin.cabal
- − utils/hpc/hpc.wrapper
Changes:
=====================================
.gitmodules
=====================================
@@ -110,3 +110,6 @@
[submodule "libraries/exceptions"]
path = libraries/exceptions
url = https://gitlab.haskell.org/ghc/packages/exceptions.git
+[submodule "utils/hpc"]
+ path = utils/hpc
+ url = https://gitlab.haskell.org/hpc/hpc-bin.git
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -354,7 +355,10 @@ instance Outputable BCInstr where
ppr RETURN = text "RETURN"
ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
+ ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"
+ where mb_uniq = sdocOption sdocSuppressUniques $ \case
+ True -> text "<uniq>"
+ False -> ppr uniq
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -486,8 +486,7 @@ returnUnliftedReps d s szb reps = do
-- otherwise use RETURN_TUPLE with a tuple descriptor
nv_reps -> do
let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps
- args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets
- tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs)
+ tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`
PUSH_BCO tuple_bco `consOL`
unitOL RETURN_TUPLE
@@ -1050,13 +1049,9 @@ doCase d s p scrut bndr alts
p scrut
alt_bco' <- emitBc alt_bco
if ubx_tuple_frame
- then do
- let args_ptrs =
- map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))
- args_offsets
- tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs)
- return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
- `consOL` scrut_code)
+ then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
+ return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
+ `consOL` scrut_code)
else let push_alts
| not ubx_frame
= PUSH_ALTS alt_bco'
@@ -1244,11 +1239,10 @@ usePlainReturn t
-}
-tupleBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
-tupleBCO platform info pointers =
+tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
+tupleBCO platform args_info args =
mkProtoBCO platform invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
-
where
{-
The tuple BCO is never referred to by name, so we can get away
@@ -1260,18 +1254,16 @@ tupleBCO platform info pointers =
-- the first word in the frame is the call_info word,
-- which is not a pointer
- bitmap_size = trunc16W $ 1 + nativeCallSize info
- bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $
- map ((+1) . fromIntegral . bytesToWords platform . snd)
- (filter fst pointers)
+ nptrs_prefix = 1
+ (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args
+
body_code = mkSlideW 0 1 -- pop frame header
`snocOL` RETURN_TUPLE -- and add it again
-primCallBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
-primCallBCO platform args_info pointers =
+primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
+primCallBCO platform args_info args =
mkProtoBCO platform invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
-
where
{-
The primcall BCO is never referred to by name, so we can get away
@@ -1281,20 +1273,52 @@ primCallBCO platform args_info pointers =
-}
invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall")
- -- the first three words in the frame are the BCO describing the
- -- pointers in the frame, the call_info word and the pointer
- -- to the Cmm function being called. None of these is a pointer that
- -- should be followed by the garbage collector
- bitmap_size = trunc16W $ 2 + nativeCallSize args_info
- bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $
- map ((+2) . fromIntegral . bytesToWords platform . snd)
- (filter fst pointers)
+ -- The first two words in the frame (after the BCO) are the call_info word
+ -- and the pointer to the Cmm function being called. Neither of these is a
+ -- pointer that should be followed by the garbage collector.
+ nptrs_prefix = 2
+ (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args
+
-- if the primcall BCO is ever run it's a bug, since the BCO should only
-- be pushed immediately before running the PRIMCALL bytecode instruction,
-- which immediately leaves the interpreter to jump to the stg_primcall_info
-- Cmm function
body_code = unitOL CASEFAIL
+-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by
+-- some number of arguments.
+mkStackBitmap
+ :: Platform
+ -> WordOff
+ -- ^ The number of nonpointer words that prefix the arguments.
+ -> NativeCallInfo
+ -> [(PrimRep, ByteOff)]
+ -- ^ The stack layout of the arguments, where each offset is relative to the
+ -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned,
+ -- and the list must be sorted in order of ascending offset (i.e. bottom to top).
+ -> (Word16, [StgWord])
+mkStackBitmap platform nptrs_prefix args_info args
+ = (bitmap_size, bitmap)
+ where
+ bitmap_size = trunc16W $ nptrs_prefix + arg_bottom
+ bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets
+
+ arg_bottom = nativeCallSize args_info
+ ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset)
+ $ mapMaybe get_ptr_offset args
+
+ get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff
+ get_ptr_offset (rep, byte_offset)
+ | isFollowableArg (toArgRep platform rep) = Just byte_offset
+ | otherwise = Nothing
+
+ convert_arg_offset :: ByteOff -> WordOff
+ convert_arg_offset arg_offset =
+ -- The argument offsets are relative to `arg_bottom`, but
+ -- `intsToReverseBitmap` expects offsets from the top, so we need to flip
+ -- them around.
+ nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset)
+
-- -----------------------------------------------------------------------------
-- Deal with a primitive call to native code.
@@ -1322,15 +1346,12 @@ generatePrimCall d s p target _mb_unit _result_ty args
(args_info, args_offsets) =
layoutNativeCall profile
NativePrimCall
- d
+ 0
(primRepCmmType platform . argPrimRep)
nv_args
- args_ptrs :: [(Bool, ByteOff)]
- args_ptrs =
- map (\(r, off) ->
- (isFollowableArg (toArgRep platform . argPrimRep $ r), off))
- args_offsets
+ prim_args_offsets = mapFst argPrimRep args_offsets
+ shifted_args_offsets = mapSnd (+ d) args_offsets
push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1
push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1
@@ -1347,8 +1368,8 @@ generatePrimCall d s p target _mb_unit _result_ty args
go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
- push_args <- go d [] args_offsets
- args_bco <- emitBc (primCallBCO platform args_info args_ptrs)
+ push_args <- go d [] shifted_args_offsets
+ args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)
return $ mconcat push_args `appOL`
(push_target `consOL`
push_info `consOL`
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -293,7 +293,10 @@ isElfTarget = anyTargetOs elfOSes
-- TODO: Windows supports lazy binding (but GHC doesn't currently support
-- dynamic way on Windows anyways).
hostSupportsRPaths :: Action Bool
-hostSupportsRPaths = anyHostOs (elfOSes ++ machoOSes)
+hostSupportsRPaths = do
+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/23011
+ isOpenBSD <- anyHostOs ["openbsd"]
+ if not isOpenBSD then anyHostOs (elfOSes ++ machoOSes) else pure False
-- | Check whether the target supports GHCi.
ghcWithInterpreter :: Action Bool
=====================================
rts/linker/Elf.c
=====================================
@@ -872,12 +872,14 @@ ocGetNames_ELF ( ObjectCode* oc )
else if (!oc->imageMapped || size < getPageSize() / 3) {
bool executable = kind == SECTIONKIND_CODE_OR_RODATA;
m32_allocator *allocator = executable ? oc->rx_m32 : oc->rw_m32;
- // align on 16 bytes. The reason being that llvm will emit see
- // paddq statements for x86_64 under optimisation and load from
- // RODATA sections. Specifically .rodata.cst16. However we don't
- // handle the cst part in any way what so ever, so 16 seems
- // better than 8.
- start = m32_alloc(allocator, size, 16);
+ // Correctly align the section. This is particularly important for
+ // the alignment of .rodata.cstNN sections.
+ //
+ // llvm will emit see paddq statements for x86_64 under
+ // optimisation and load from RODATA sections, specifically
+ // .rodata.cst16. Also we may encounter .rodata.cst32 sections
+ // in objects using AVX instructions (see #23066).
+ start = m32_alloc(allocator, size, align);
if (start == NULL) goto fail;
memcpy(start, oc->image + offset, size);
alloc = SECTION_M32;
=====================================
testsuite/tests/bytecode/T23068.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+module T23068 where
+import GHC.Exts
+
+f :: () -> (# Int, Int #)
+f () = (# 0, 0 #)
+
+g :: () -> (# Int#, Int#, Int #)
+g () = (# 0#, 0#, 0 #)
=====================================
testsuite/tests/bytecode/T23068.script
=====================================
@@ -0,0 +1 @@
+:l T23068
=====================================
testsuite/tests/bytecode/T23068.stdout
=====================================
@@ -0,0 +1,71 @@
+
+==================== Proto-BCOs ====================
+ProtoBCO T23068.g#1 []:
+ \r [ds] case of wild
+ bitmap: 1 [0]
+ PUSH_ALTS P
+ ProtoBCO wild#0 []:
+ { () -> let bcprep = ... in ...
+ bitmap: 1 [0]
+ ALLOC_PAP 1 0
+ PUSH_BCO
+ ProtoBCO bcprep#1 []:
+ \r [void] break<0>() let sat = ... in ...
+ bitmap: 0 []
+ BRK_FUN 0 <uniq> <cc>
+ PUSH_UBX (1) 0#
+ PACK GHC.Types.I# 1
+ PUSH_L 0
+ PUSH_UBX (1) 0#
+ PUSH_UBX (1) 0#
+ SLIDE 3 1
+ PUSH_UBX (1) 7##
+ PUSH_BCO
+ ProtoBCO tuple#0 []:
+ bitmap: 4 [7]
+ SLIDE 0 1
+ RETURN_TUPLE
+ RETURN_TUPLE
+ MKPAP 0 words, 1 stkoff
+ PUSH_APPLY_V
+ PUSH_L 1
+ SLIDE 2 5
+ ENTER
+ PUSH_L 2
+ ENTER
+
+ProtoBCO T23068.f#1 []:
+ \r [ds] case of wild
+ bitmap: 1 [0]
+ PUSH_ALTS P
+ ProtoBCO wild#0 []:
+ { () -> let bcprep = ... in ...
+ bitmap: 1 [0]
+ ALLOC_PAP 1 0
+ PUSH_BCO
+ ProtoBCO bcprep#1 []:
+ \r [void] break<1>() let sat = ... in ...
+ bitmap: 0 []
+ BRK_FUN 1 <uniq> <cc>
+ PUSH_UBX (1) 0#
+ PACK GHC.Types.I# 1
+ PUSH_UBX (1) 0#
+ PACK GHC.Types.I# 1
+ PUSH_LL 1 0
+ SLIDE 2 2
+ PUSH_UBX (1) 3##
+ PUSH_BCO
+ ProtoBCO tuple#0 []:
+ bitmap: 3 [1]
+ SLIDE 0 1
+ RETURN_TUPLE
+ RETURN_TUPLE
+ MKPAP 0 words, 1 stkoff
+ PUSH_APPLY_V
+ PUSH_L 1
+ SLIDE 2 5
+ ENTER
+ PUSH_L 2
+ ENTER
+
+
=====================================
testsuite/tests/bytecode/all.T
=====================================
@@ -0,0 +1,3 @@
+ghci_dump_bcos = [only_ways(['ghci']), extra_run_opts('-dno-typeable-binds -dsuppress-uniques -ddump-bcos')]
+
+test('T23068', ghci_dump_bcos + [filter_stdout_lines(r'.*bitmap: .*')], ghci_script, ['T23068.script'])
=====================================
testsuite/tests/rts/linker/Makefile
=====================================
@@ -12,6 +12,11 @@ section_alignment:
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RTSOPTS) -v0 --make -no-rtsopts-suggestions -no-hs-main -o runner runner.c
./runner section_alignment.o isAligned
+T23066:
+ '$(TEST_CC)' $(TEST_CC_OPTS) -c -o T23066_c.o T23066_c.c
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RTSOPTS) -v0 --make -no-rtsopts-suggestions -no-hs-main -o runner runner.c -static
+ ./runner T23066_c.o isAligned
+
T2615-prep:
$(RM) libfoo_T2615.so
'$(TEST_HC)' $(TEST_HC_OPTS) -fPIC -c libfoo_T2615.c -o libfoo_T2615.o
=====================================
testsuite/tests/rts/linker/T23066.stdout
=====================================
@@ -0,0 +1,2 @@
+Linking: path = T23066_c.o, symname = isAligned
+1
=====================================
testsuite/tests/rts/linker/T23066_c.c
=====================================
@@ -0,0 +1,42 @@
+#include<stdint.h>
+#include<stdio.h>
+
+extern int foo32_1, foo32_2;
+
+// The bug in #23066 was that we wouldn't correctly align 32-bytes aligned
+// sections, except by chance (we were always aligning on 16 bytes).
+//
+// Hence we intersperse two 16-bytes aligned sections with two 32-bytes aligned
+// sections to ensure that at least one of the 32-bytes aligned section
+// triggers the bug (the order of the sections seems to be preserved).
+
+__asm__(
+" .section pad16_1,\"aM\", at progbits,16\n\t"
+" .align 16\n\t"
+" .byte 0\n\t"
+"\n\t"
+" .global foo32_1\n\t"
+" .section sfoo32_1,\"aM\", at progbits,32\n\t"
+" .align 32\n\t"
+"foo32_1:\n\t"
+" .byte 0\n\t"
+"\n\t"
+" .section pad16_2,\"aM\", at progbits,16\n\t"
+" .align 16\n\t"
+" .byte 0\n\t"
+"\n\t"
+" .global foo32_2\n\t"
+" .section sfoo32_2,\"aM\", at progbits,32\n\t"
+" .align 32\n\t"
+"foo32_2:\n\t"
+" .byte 0\n\t"
+);
+
+
+#define ALIGN32(x) (((intptr_t)(&x) & 0x1F) == 0)
+
+int isAligned() {
+ //printf("%p\n", &foo32_1);
+ //printf("%p\n", &foo32_2);
+ return (ALIGN32(foo32_1) && ALIGN32(foo32_2));
+}
=====================================
testsuite/tests/rts/linker/all.T
=====================================
@@ -16,6 +16,14 @@ test('section_alignment',
],
makefile_test, [])
+######################################
+test('T23066',
+ [ unless(arch('x86_64'), skip)
+ , unless(opsys('linux'), skip)
+ , extra_files(['runner.c', 'T23066_c.c'])
+ ],
+ makefile_test, [])
+
######################################
# Test to see if linker scripts link properly to real ELF files
test('T2615',
=====================================
utils/hpc
=====================================
@@ -0,0 +1 @@
+Subproject commit b376045cb3f3d28815ca29d9c07df2e843cec1c3
=====================================
utils/hpc/HpcCombine.hs deleted
=====================================
@@ -1,197 +0,0 @@
----------------------------------------------------------
--- The main program for the hpc-add tool, part of HPC.
--- Andy Gill, Oct 2006
----------------------------------------------------------
-
-module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
-
-import Trace.Hpc.Tix
-import Trace.Hpc.Util
-
-import HpcFlags
-
-import Control.Monad
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-
-------------------------------------------------------------------------------
-sum_options :: FlagOptSeq
-sum_options
- = excludeOpt
- . includeOpt
- . outputOpt
- . unionModuleOpt
- . verbosityOpt
-
-sum_plugin :: Plugin
-sum_plugin = Plugin { name = "sum"
- , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
- , options = sum_options
- , summary = "Sum multiple .tix files in a single .tix file"
- , implementation = sum_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-combine_options :: FlagOptSeq
-combine_options
- = excludeOpt
- . includeOpt
- . outputOpt
- . combineFunOpt
- . combineFunOptInfo
- . unionModuleOpt
- . verbosityOpt
-
-combine_plugin :: Plugin
-combine_plugin = Plugin { name = "combine"
- , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
- , options = combine_options
- , summary = "Combine two .tix files in a single .tix file"
- , implementation = combine_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-map_options :: FlagOptSeq
-map_options
- = excludeOpt
- . includeOpt
- . outputOpt
- . mapFunOpt
- . mapFunOptInfo
- . unionModuleOpt
- . verbosityOpt
-
-map_plugin :: Plugin
-map_plugin = Plugin { name = "map"
- , usage = "[OPTION] .. <TIX_FILE> "
- , options = map_options
- , summary = "Map a function over a single .tix file"
- , implementation = map_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-------------------------------------------------------------------------------
-
-sum_main :: Flags -> [String] -> IO ()
-sum_main _ [] = hpcError sum_plugin $ "no .tix file specified"
-sum_main flags (first_file:more_files) = do
- Just tix <- readTix first_file
-
- tix' <- foldM (mergeTixFile flags (+))
- (filterTix flags tix)
- more_files
-
- case outputFile flags of
- "-" -> putStrLn (show tix')
- out -> writeTix out tix'
-
-combine_main :: Flags -> [String] -> IO ()
-combine_main flags [first_file,second_file] = do
- let f = theCombineFun (combineFun flags)
-
- Just tix1 <- readTix first_file
- Just tix2 <- readTix second_file
-
- let tix = mergeTix (mergeModule flags)
- f
- (filterTix flags tix1)
- (filterTix flags tix2)
-
- case outputFile flags of
- "-" -> putStrLn (show tix)
- out -> writeTix out tix
-combine_main _ _ = hpcError combine_plugin $ "need exactly two .tix files to combine"
-
-map_main :: Flags -> [String] -> IO ()
-map_main flags [first_file] = do
- let f = thePostFun (postFun flags)
-
- Just tix <- readTix first_file
-
- let (Tix inside_tix) = filterTix flags tix
- let tix' = Tix [ TixModule m p i (map f t)
- | TixModule m p i t <- inside_tix
- ]
-
- case outputFile flags of
- "-" -> putStrLn (show tix')
- out -> writeTix out tix'
-map_main _ [] = hpcError map_plugin $ "no .tix file specified"
-map_main _ _ = hpcError map_plugin $ "to many .tix files specified"
-
-mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
-mergeTixFile flags fn tix file_name = do
- Just new_tix <- readTix file_name
- return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
-
--- could allow different numbering on the module info,
--- as long as the total is the same; will require normalization.
-
-mergeTix :: MergeFun
- -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
-mergeTix modComb f
- (Tix t1)
- (Tix t2) = Tix
- [ case (Map.lookup m fm1,Map.lookup m fm2) of
- -- todo, revisit the semantics of this combination
- (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
- | hash1 /= hash2
- || length tix1 /= length tix2
- || len1 /= length tix1
- || len2 /= length tix2
- -> error $ "mismatched in module " ++ m
- | otherwise ->
- TixModule m hash1 len1 (zipWith f tix1 tix2)
- (Just m1,Nothing) ->
- m1
- (Nothing,Just m2) ->
- m2
- _ -> error "impossible"
- | m <- Set.toList (theMergeFun modComb m1s m2s)
- ]
- where
- m1s = Set.fromList $ map tixModuleName t1
- m2s = Set.fromList $ map tixModuleName t2
-
- fm1 = Map.fromList [ (tixModuleName tix,tix)
- | tix <- t1
- ]
- fm2 = Map.fromList [ (tixModuleName tix,tix)
- | tix <- t2
- ]
-
-
--- What I would give for a hyperstrict :-)
--- This makes things about 100 times faster.
-class Strict a where
- strict :: a -> a
-
-instance Strict Integer where
- strict i = i
-
-instance Strict Int where
- strict i = i
-
-instance Strict Hash where -- should be fine, because Hash is a newtype round an Int
- strict i = i
-
-instance Strict Char where
- strict i = i
-
-instance Strict a => Strict [a] where
- strict (a:as) = (((:) $! strict a) $! strict as)
- strict [] = []
-
-instance (Strict a, Strict b) => Strict (a,b) where
- strict (a,b) = (((,) $! strict a) $! strict b)
-
-instance Strict Tix where
- strict (Tix t1) =
- Tix $! strict t1
-
-instance Strict TixModule where
- strict (TixModule m1 p1 i1 t1) =
- ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
=====================================
utils/hpc/HpcDraft.hs deleted
=====================================
@@ -1,144 +0,0 @@
-module HpcDraft (draft_plugin) where
-
-import Trace.Hpc.Tix
-import Trace.Hpc.Mix
-import Trace.Hpc.Util
-
-import HpcFlags
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import HpcUtils
-import Data.Tree
-
-------------------------------------------------------------------------------
-draft_options :: FlagOptSeq
-draft_options
- = excludeOpt
- . includeOpt
- . srcDirOpt
- . hpcDirOpt
- . resetHpcDirsOpt
- . outputOpt
- . verbosityOpt
-
-draft_plugin :: Plugin
-draft_plugin = Plugin { name = "draft"
- , usage = "[OPTION] .. <TIX_FILE>"
- , options = draft_options
- , summary = "Generate draft overlay that provides 100% coverage"
- , implementation = draft_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-------------------------------------------------------------------------------
-
-draft_main :: Flags -> [String] -> IO ()
-draft_main _ [] = error "draft_main: unhandled case: []"
-draft_main hpcflags (progName:mods) = do
- let hpcflags1 = hpcflags
- { includeMods = Set.fromList mods
- `Set.union`
- includeMods hpcflags }
- let prog = getTixFileName $ progName
- tix <- readTix prog
- case tix of
- Just (Tix tickCounts) -> do
- outs <- sequence
- [ makeDraft hpcflags1 tixModule
- | tixModule@(TixModule m _ _ _) <- tickCounts
- , allowModule hpcflags1 m
- ]
- case outputFile hpcflags1 of
- "-" -> putStrLn (unlines outs)
- out -> writeFile out (unlines outs)
- Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName
-
-
-makeDraft :: Flags -> TixModule -> IO String
-makeDraft hpcflags tix = do
- let modu = tixModuleName tix
- tixs = tixModuleTixs tix
-
- (Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix)
-
- let forest = createMixEntryDom
- [ (srcspan,(box,v > 0))
- | ((srcspan,box),v) <- zip entries tixs
- ]
-
--- let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
--- putStrLn $ drawForest $ map (fmap show) $ forest
-
- let non_ticked = findNotTickedFromList forest
-
- hs <- readFileFromPath (hpcError draft_plugin) filepath (srcDirs hpcflags)
-
- let hsMap :: Map.Map Int String
- hsMap = Map.fromList (zip [1..] $ lines hs)
-
- let quoteString = show
-
- let firstLine pos = case fromHpcPos pos of
- (ln,_,_,_) -> ln
-
-
- let showPleaseTick :: Int -> PleaseTick -> String
- showPleaseTick d (TickFun str pos) =
- spaces d ++ "tick function \"" ++ last str ++ "\" "
- ++ "on line " ++ show (firstLine pos) ++ ";"
- showPleaseTick d (TickExp pos) =
- spaces d ++ "tick "
- ++ if '\n' `elem` txt
- then "at position " ++ show pos ++ ";"
- else quoteString txt ++ " " ++ "on line " ++ show (firstLine pos) ++ ";"
-
- where
- txt = grabHpcPos hsMap pos
-
- showPleaseTick d (TickInside [str] _ pleases) =
- spaces d ++ "inside \"" ++ str ++ "\" {\n" ++
- showPleaseTicks (d + 2) pleases ++
- spaces d ++ "}"
-
- showPleaseTick _ (TickInside _ _ _)
- = error "showPleaseTick: Unhandled case TickInside"
-
- showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases)
-
- spaces d = take d (repeat ' ')
-
- return $ "module " ++ show (fixPackageSuffix modu) ++ " {\n" ++
- showPleaseTicks 2 non_ticked ++ "}"
-
-fixPackageSuffix :: String -> String
-fixPackageSuffix modu = case span (/= '/') modu of
- (before,'/':after) -> before ++ ":" ++ after
- _ -> modu
-
-data PleaseTick
- = TickFun [String] HpcPos
- | TickExp HpcPos
- | TickInside [String] HpcPos [PleaseTick]
- deriving Show
-
-mkTickInside :: [String] -> HpcPos -> [PleaseTick]
- -> [PleaseTick] -> [PleaseTick]
-mkTickInside _ _ [] = id
-mkTickInside nm pos inside = (TickInside nm pos inside :)
-
-findNotTickedFromTree :: MixEntryDom [(BoxLabel,Bool)] -> [PleaseTick]
-findNotTickedFromTree (Node (pos,(ExpBox {},False):_) _) = [TickExp pos]
-findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
- = [ TickFun nm pos ]
-findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _)
- = [ TickFun nm pos ]
-findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):_) children)
- = mkTickInside nm pos (findNotTickedFromList children) []
-findNotTickedFromTree (Node (pos,_:others) children) =
- findNotTickedFromTree (Node (pos,others) children)
-findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children
-
-findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
-findNotTickedFromList = concatMap findNotTickedFromTree
=====================================
utils/hpc/HpcFlags.hs deleted
=====================================
@@ -1,268 +0,0 @@
--- (c) 2007 Andy Gill
-
-module HpcFlags where
-
-import System.Console.GetOpt
-import qualified Data.Set as Set
-import Data.Char
-import Trace.Hpc.Tix
-import Trace.Hpc.Mix
-import System.Exit
-import System.FilePath
-
-data Flags = Flags
- { outputFile :: String
- , includeMods :: Set.Set String
- , excludeMods :: Set.Set String
- , hpcDirs :: [String]
- , srcDirs :: [String]
- , destDir :: String
-
- , perModule :: Bool
- , decList :: Bool
- , xmlOutput :: Bool
-
- , funTotals :: Bool
- , altHighlight :: Bool
-
- , combineFun :: CombineFun -- tick-wise combine
- , postFun :: PostFun --
- , mergeModule :: MergeFun -- module-wise merge
-
- , verbosity :: Verbosity
- }
-
-default_flags :: Flags
-default_flags = Flags
- { outputFile = "-"
- , includeMods = Set.empty
- , excludeMods = Set.empty
- , hpcDirs = [".hpc"]
- , srcDirs = []
- , destDir = "."
-
- , perModule = False
- , decList = False
- , xmlOutput = False
-
- , funTotals = False
- , altHighlight = False
-
- , combineFun = ADD
- , postFun = ID
- , mergeModule = INTERSECTION
-
- , verbosity = Normal
- }
-
-
-data Verbosity = Silent | Normal | Verbose
- deriving (Eq, Ord)
-
-verbosityFromString :: String -> Verbosity
-verbosityFromString "0" = Silent
-verbosityFromString "1" = Normal
-verbosityFromString "2" = Verbose
-verbosityFromString v = error $ "unknown verbosity: " ++ v
-
-
--- We do this after reading flags, because the defaults
--- depends on if specific flags we used.
-
-default_final_flags :: Flags -> Flags
-default_final_flags flags = flags
- { srcDirs = if null (srcDirs flags)
- then ["."]
- else srcDirs flags
- }
-
-type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]
-
-noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
-noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail
-
-anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
-anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail
-
-infoArg :: String -> FlagOptSeq
-infoArg info = (:) $ Option [] [] (NoArg $ id) info
-
-excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
- destDirOpt, outputOpt, verbosityOpt,
- perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
- altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
- mapFunOptInfo, unionModuleOpt :: FlagOptSeq
-excludeOpt = anArg "exclude" "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
- $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
-
-includeOpt = anArg "include" "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
- $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
-
-hpcDirOpt = anArg "hpcdir" "append sub-directory that contains .mix files" "DIR"
- (\ a f -> f { hpcDirs = hpcDirs f ++ [a] })
- . infoArg "default .hpc [rarely used]"
-
-resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's"
- (\ f -> f { hpcDirs = [] })
- . infoArg "[rarely used]"
-
-srcDirOpt = anArg "srcdir" "path to source directory of .hs files" "DIR"
- (\ a f -> f { srcDirs = srcDirs f ++ [a] })
- . infoArg "multi-use of srcdir possible"
-
-destDirOpt = anArg "destdir" "path to write output to" "DIR"
- $ \ a f -> f { destDir = a }
-
-
-outputOpt = anArg "output" "output FILE" "FILE" $ \ a f -> f { outputFile = a }
-
-verbosityOpt = anArg "verbosity" "verbosity level, 0-2" "[0-2]"
- (\ a f -> f { verbosity = verbosityFromString a })
- . infoArg "default 1"
-
--- markup
-
-perModuleOpt = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
-decListOpt = noArg "decl-list" "show unused decls" $ \ f -> f { decList = True }
-xmlOutputOpt = noArg "xml-output" "show output in XML" $ \ f -> f { xmlOutput = True }
-funTotalsOpt = noArg "fun-entry-count" "show top-level function entry counts"
- $ \ f -> f { funTotals = True }
-altHighlightOpt
- = noArg "highlight-covered" "highlight covered code, rather that code gaps"
- $ \ f -> f { altHighlight = True }
-
-combineFunOpt = anArg "function"
- "combine .tix files with join function, default = ADD" "FUNCTION"
- $ \ a f -> case reads (map toUpper a) of
- [(c,"")] -> f { combineFun = c }
- _ -> error $ "no such combine function : " ++ a
-combineFunOptInfo = infoArg
- $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)
-
-mapFunOpt = anArg "function"
- "apply function to .tix files, default = ID" "FUNCTION"
- $ \ a f -> case reads (map toUpper a) of
- [(c,"")] -> f { postFun = c }
- _ -> error $ "no such combine function : " ++ a
-mapFunOptInfo = infoArg
- $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)
-
-unionModuleOpt = noArg "union"
- "use the union of the module namespace (default is intersection)"
- $ \ f -> f { mergeModule = UNION }
-
-
--------------------------------------------------------------------------------
-
-readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
-readMixWithFlags flags modu = readMix [ dir </> hpcDir
- | dir <- srcDirs flags
- , hpcDir <- hpcDirs flags
- ] modu
-
--------------------------------------------------------------------------------
-
-command_usage :: Plugin -> IO ()
-command_usage plugin =
- putStrLn $
- "Usage: hpc " ++ (name plugin) ++ " " ++
- (usage plugin) ++
- "\n" ++ summary plugin ++ "\n" ++
- if null (options plugin [])
- then ""
- else usageInfo "\n\nOptions:\n" (options plugin [])
-
-hpcError :: Plugin -> String -> IO a
-hpcError plugin msg = do
- putStrLn $ "Error: " ++ msg
- command_usage plugin
- exitFailure
-
--------------------------------------------------------------------------------
-
-data Plugin = Plugin { name :: String
- , usage :: String
- , options :: FlagOptSeq
- , summary :: String
- , implementation :: Flags -> [String] -> IO ()
- , init_flags :: Flags
- , final_flags :: Flags -> Flags
- }
-
-------------------------------------------------------------------------------
-
--- filterModules takes a list of candidate modules,
--- and
--- * excludes the excluded modules
--- * includes the rest if there are no explicitly included modules
--- * otherwise, accepts just the included modules.
-
-allowModule :: Flags -> String -> Bool
-allowModule flags full_mod
- | full_mod' `Set.member` excludeMods flags = False
- | pkg_name `Set.member` excludeMods flags = False
- | mod_name `Set.member` excludeMods flags = False
- | Set.null (includeMods flags) = True
- | full_mod' `Set.member` includeMods flags = True
- | pkg_name `Set.member` includeMods flags = True
- | mod_name `Set.member` includeMods flags = True
- | otherwise = False
- where
- full_mod' = pkg_name ++ mod_name
- -- pkg name always ends with '/', main
- (pkg_name,mod_name) =
- case span (/= '/') full_mod of
- (p,'/':m) -> (p ++ ":",m)
- (m,[]) -> (":",m)
- _ -> error "impossible case in allowModule"
-
-filterTix :: Flags -> Tix -> Tix
-filterTix flags (Tix tixs) =
- Tix $ filter (allowModule flags . tixModuleName) tixs
-
-
-
-------------------------------------------------------------------------------
--- HpcCombine specifics
-
-data CombineFun = ADD | DIFF | SUB
- deriving (Eq,Show, Read, Enum)
-
-theCombineFun :: CombineFun -> Integer -> Integer -> Integer
-theCombineFun fn = case fn of
- ADD -> \ l r -> l + r
- SUB -> \ l r -> max 0 (l - r)
- DIFF -> \ g b -> if g > 0 then 0 else min 1 b
-
-foldFuns :: [ (String,CombineFun) ]
-foldFuns = [ (show comb,comb)
- | comb <- [ADD .. SUB]
- ]
-
-data PostFun = ID | INV | ZERO
- deriving (Eq,Show, Read, Enum)
-
-thePostFun :: PostFun -> Integer -> Integer
-thePostFun ID x = x
-thePostFun INV 0 = 1
-thePostFun INV _ = 0
-thePostFun ZERO _ = 0
-
-postFuns :: [(String, PostFun)]
-postFuns = [ (show pos,pos)
- | pos <- [ID .. ZERO]
- ]
-
-
-data MergeFun = INTERSECTION | UNION
- deriving (Eq,Show, Read, Enum)
-
-theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a
-theMergeFun INTERSECTION = Set.intersection
-theMergeFun UNION = Set.union
-
-mergeFuns :: [(String, MergeFun)]
-mergeFuns = [ (show pos,pos)
- | pos <- [INTERSECTION,UNION]
- ]
-
=====================================
utils/hpc/HpcLexer.hs deleted
=====================================
@@ -1,57 +0,0 @@
-module HpcLexer where
-
-import Data.Char
-
-data Token
- = ID String
- | SYM Char
- | INT Int
- | STR String
- | CAT String
- deriving (Eq,Show)
-
-initLexer :: String -> [Token]
-initLexer str = [ t | (_,_,t) <- lexer str 1 1 ]
-
-lexer :: String -> Int -> Int -> [(Int,Int,Token)]
-lexer (c:cs) line column
- | c == '\n' = lexer cs (succ line) 1
- | c == '\"' = lexerSTR cs line (succ column)
- | c == '[' = lexerCAT cs "" line (succ column)
- | c `elem` "{};-:"
- = (line,column,SYM c) : lexer cs line (succ column)
- | isSpace c = lexer cs line (succ column)
- | isAlpha c = lexerKW cs [c] line (succ column)
- | isDigit c = lexerINT cs [c] line (succ column)
- | otherwise = error "lexer failure"
-lexer [] _ _ = []
-
-lexerKW :: String -> String -> Int -> Int -> [(Int,Int,Token)]
-lexerKW (c:cs) s line column
- | isAlpha c = lexerKW cs (s ++ [c]) line (succ column)
-lexerKW other s line column = (line,column,ID s) : lexer other line column
-
-lexerINT :: String -> String -> Int -> Int -> [(Int,Int,Token)]
-lexerINT (c:cs) s line column
- | isDigit c = lexerINT cs (s ++ [c]) line (succ column)
-lexerINT other s line column = (line,column,INT (read s)) : lexer other line column
-
--- not technically correct for the new column count, but a good approximation.
-lexerSTR :: String -> Int -> Int -> [(Int,Int,Token)]
-lexerSTR cs line column
- = case lex ('"' : cs) of
- [(str,rest)] -> (line,succ column,STR (read str))
- : lexer rest line (length (show str) + column + 1)
- _ -> error "bad string"
-
-lexerCAT :: String -> String -> Int -> Int -> [(Int,Int,Token)]
-lexerCAT (c:cs) s line column
- | c == ']' = (line,column,CAT s) : lexer cs line (succ column)
- | otherwise = lexerCAT cs (s ++ [c]) line (succ column)
-lexerCAT [] _ _ _ = error "lexer failure in CAT"
-
-test :: IO ()
-test = do
- t <- readFile "EXAMPLE.tc"
- print (initLexer t)
-
=====================================
utils/hpc/HpcMarkup.hs deleted
=====================================
@@ -1,485 +0,0 @@
----------------------------------------------------------
--- The main program for the hpc-markup tool, part of HPC.
--- Andy Gill and Colin Runciman, June 2006
----------------------------------------------------------
-
-module HpcMarkup (markup_plugin) where
-
-import Trace.Hpc.Mix
-import Trace.Hpc.Tix
-import Trace.Hpc.Util (HpcPos, fromHpcPos, writeFileUtf8)
-
-import HpcFlags
-import HpcUtils
-
-import System.FilePath
-import Data.List (sortBy, find)
-import Data.Maybe(fromJust)
-import Data.Semigroup as Semi
-import Data.Array
-import Control.Monad
-import qualified Data.Set as Set
-
-------------------------------------------------------------------------------
-
-markup_options :: FlagOptSeq
-markup_options
- = excludeOpt
- . includeOpt
- . srcDirOpt
- . hpcDirOpt
- . resetHpcDirsOpt
- . funTotalsOpt
- . altHighlightOpt
- . destDirOpt
- . verbosityOpt
-
-markup_plugin :: Plugin
-markup_plugin = Plugin { name = "markup"
- , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
- , options = markup_options
- , summary = "Markup Haskell source with program coverage"
- , implementation = markup_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-------------------------------------------------------------------------------
-
-markup_main :: Flags -> [String] -> IO ()
-markup_main flags (prog:modNames) = do
- let hpcflags1 = flags
- { includeMods = Set.fromList modNames
- `Set.union`
- includeMods flags }
- let Flags
- { funTotals = theFunTotals
- , altHighlight = invertOutput
- , destDir = dest_dir
- } = hpcflags1
-
- mtix <- readTix (getTixFileName prog)
- Tix tixs <- case mtix of
- Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
- Just a -> return a
-
- mods <-
- sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
- | tix <- tixs
- , allowModule hpcflags1 (tixModuleName tix)
- ]
-
- let index_name = "hpc_index"
- index_fun = "hpc_index_fun"
- index_alt = "hpc_index_alt"
- index_exp = "hpc_index_exp"
-
- let writeSummary filename cmp = do
- let mods' = sortBy cmp mods
-
- unless (verbosity flags < Normal) $
- putStrLn $ "Writing: " ++ (filename <.> "html")
-
- writeFileUtf8 (dest_dir </> filename <.> "html") $
- "<html>" ++
- "<head>" ++
- "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">" ++
- "<style type=\"text/css\">" ++
- "table.bar { background-color: #f25913; }\n" ++
- "td.bar { background-color: #60de51; }\n" ++
- "td.invbar { background-color: #f25913; }\n" ++
- "table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++
- ".dashboard td { border: solid 1px black }\n" ++
- ".dashboard th { border: solid 1px black }\n" ++
- "</style>\n" ++
- "</head>" ++
- "<body>" ++
- "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
- "<tr>" ++
- "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
- "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
- "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
- "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
- "</tr>" ++
- "<tr>" ++
- "<th>%</th>" ++
- "<th colspan=2>covered / total</th>" ++
- "<th>%</th>" ++
- "<th colspan=2>covered / total</th>" ++
- "<th>%</th>" ++
- "<th colspan=2>covered / total</th>" ++
- "</tr>" ++
- concat [ showModuleSummary (modName,fileName,modSummary)
- | (modName,fileName,modSummary) <- mods'
- ] ++
- "<tr></tr>" ++
- showTotalSummary (mconcat
- [ modSummary
- | (_,_,modSummary) <- mods'
- ])
- ++ "</table></body></html>\n"
-
- writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2
-
- writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
- compare (percent (topFunTicked s2) (topFunTotal s2))
- (percent (topFunTicked s1) (topFunTotal s1))
-
- writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
- compare (percent (altTicked s2) (altTotal s2))
- (percent (altTicked s1) (altTotal s1))
-
- writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
- compare (percent (expTicked s2) (expTotal s2))
- (percent (expTicked s1) (expTotal s1))
-
-
-markup_main _ []
- = hpcError markup_plugin $ "no .tix file or executable name specified"
-
--- Add characters to the left of a string until it is at least as
--- large as requested.
-padLeft :: Int -> Char -> String -> String
-padLeft n c str = go n str
- where
- -- If the string is already long enough, stop traversing it.
- go 0 _ = str
- go k [] = replicate k c ++ str
- go k (_:xs) = go (k-1) xs
-
-genHtmlFromMod
- :: String
- -> Flags
- -> TixModule
- -> Bool
- -> Bool
- -> IO (String, [Char], ModuleSummary)
-genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
- let theHsPath = srcDirs flags
- let modName0 = tixModuleName tix
-
- (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix)
-
- let arr_tix :: Array Int Integer
- arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
- $ tixModuleTixs tix
-
- let tickedWith :: Int -> Integer
- tickedWith n = arr_tix ! n
-
- isTicked n = tickedWith n /= 0
-
- let info = [ (pos,theMarkup)
- | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
- , let binBox = case (isTicked gid,isTicked (gid+1)) of
- (False,False) -> []
- (True,False) -> [TickedOnlyTrue]
- (False,True) -> [TickedOnlyFalse]
- (True,True) -> []
- , let tickBox = if isTicked gid
- then [IsTicked]
- else [NotTicked]
- , theMarkup <- case boxLabel of
- ExpBox {} -> tickBox
- TopLevelBox {}
- -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
- LocalBox {} -> tickBox
- BinBox _ True -> binBox
- _ -> []
- ]
-
-
- let modSummary = foldr (.) id
- [ \ st ->
- case boxLabel of
- ExpBox False
- -> st { expTicked = ticked (expTicked st)
- , expTotal = succ (expTotal st)
- }
- ExpBox True
- -> st { expTicked = ticked (expTicked st)
- , expTotal = succ (expTotal st)
- , altTicked = ticked (altTicked st)
- , altTotal = succ (altTotal st)
- }
- TopLevelBox _ ->
- st { topFunTicked = ticked (topFunTicked st)
- , topFunTotal = succ (topFunTotal st)
- }
- _ -> st
- | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
- , let ticked = if isTicked gid
- then succ
- else id
- ] $ mempty
-
- -- add prefix to modName argument
- content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
-
- let content' = markup tabStop info content
- let addLine n xs = "<span class=\"lineno\">" ++ padLeft 5 ' ' (show n) ++ " </span>" ++ xs
- let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
- let fileName = modName0 <.> "hs" <.> "html"
- unless (verbosity flags < Normal) $
- putStrLn $ "Writing: " ++ fileName
- writeFileUtf8 (dest_dir </> fileName) $
- unlines ["<html>",
- "<head>",
- "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">",
- "<style type=\"text/css\">",
- "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
- if invertOutput
- then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
- else "span.nottickedoff { background: " ++ yellow ++ "}",
- if invertOutput
- then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
- else "span.istickedoff { background: white }",
- "span.tickonlyfalse { margin: -1px; border: 1px solid " ++ red ++ "; background: " ++ red ++ " }",
- "span.tickonlytrue { margin: -1px; border: 1px solid " ++ green ++ "; background: " ++ green ++ " }",
- "span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
- if invertOutput
- then "span.decl { font-weight: bold; background: #d0c0ff }"
- else "span.decl { font-weight: bold }",
- "span.spaces { background: white }",
- "</style>",
- "</head>",
- "<body>",
- "<pre>",
- concat [
- "<span class=\"decl\">",
- "<span class=\"nottickedoff\">never executed</span> ",
- "<span class=\"tickonlytrue\">always true</span> ",
- "<span class=\"tickonlyfalse\">always false</span></span>"],
- "</pre>",
- "<pre>"] ++ addLines content' ++ "\n</pre>\n</body>\n</html>\n";
-
-
- modSummary `seq` return (modName0,fileName,modSummary)
-
-data Loc = Loc !Int !Int
- deriving (Eq,Ord,Show)
-
-data Markup
- = NotTicked
- | TickedOnlyTrue
- | TickedOnlyFalse
- | IsTicked
- | TopLevelDecl
- Bool -- display entry totals
- Integer
- deriving (Eq,Show)
-
-markup :: Int -- ^tabStop
- -> [(HpcPos,Markup)] -- random list of tick location pairs
- -> String -- text to mark up
- -> String
-markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
- where
- tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
- | (pos,mark) <- mix
- , let (ln1,c1,ln2,c2) = fromHpcPos pos
- ]
- sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
- (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs
-
-addMarkup :: Int -- tabStop
- -> String -- text to mark up
- -> Loc -- current location
- -> [(Loc,Markup)] -- stack of open ticks, with closing location
- -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
- -> String
-
--- check the pre-condition.
---addMarkup tabStop cs loc os ticks
--- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os
-
---addMarkup tabStop cs loc os@(_:_) ticks
--- | trace (show (loc,os,take 10 ticks)) False = undefined
-
--- close all open ticks, if we have reached the end
-addMarkup _ [] _loc os [] =
- concatMap (const closeTick) os
-addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
- closeTick ++ addMarkup tabStop cs loc os ticks
-
---addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
--- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks
-
-addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
- case os of
- ((_,tik'):_)
- | not (allowNesting tik0 tik')
- -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
- _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
- where
-
- addTo (t,tik) [] = [(t,tik)]
- addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs
- | otherwise = (t',tik):(t',tik'):xs
-
-addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
- -- throw away this tick, because it is from a previous place ??
- addMarkup tabStop0 cs loc os ticks
-
-addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
- | ln == ln2 && col < col2
- = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
-addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
- if c0=='\n' && os/=[] then
- concatMap (const closeTick) (downToTopLevel os) ++
- c0 : "<span class=\"spaces\">" ++ expand 1 w ++ "</span>" ++
- concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
- addMarkup tabStop0 cs' loc' os ticks
- else if c0=='\t' then
- expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
- else
- escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
- where
- (w,cs') = span (`elem` " \t") cs
- loc' = foldl (flip incBy) loc (c0:w)
- escape '>' = ">"
- escape '<' = "<"
- escape '"' = """
- escape '&' = "&"
- escape c = [c]
-
- expand :: Int -> String -> String
- expand _ "" = ""
- expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
- where
- c' = tabStopAfter 8 c
- expand c (' ':s) = ' ' : expand (c+1) s
- expand _ _ = error "bad character in string for expansion"
-
- incBy :: Char -> Loc -> Loc
- incBy '\n' (Loc ln _c) = Loc (succ ln) 1
- incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
- incBy _ (Loc ln c) = Loc ln (succ c)
-
- tabStopAfter :: Int -> Int -> Int
- tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])
-
-
-addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)
-
-openTick :: Markup -> String
-openTick NotTicked = "<span class=\"nottickedoff\">"
-openTick IsTicked = "<span class=\"istickedoff\">"
-openTick TickedOnlyTrue = "<span class=\"tickonlytrue\">"
-openTick TickedOnlyFalse = "<span class=\"tickonlyfalse\">"
-openTick (TopLevelDecl False _) = openTopDecl
-openTick (TopLevelDecl True 0)
- = "<span class=\"funcount\">-- never entered</span>" ++
- openTopDecl
-openTick (TopLevelDecl True 1)
- = "<span class=\"funcount\">-- entered once</span>" ++
- openTopDecl
-openTick (TopLevelDecl True n0)
- = "<span class=\"funcount\">-- entered " ++ showBigNum n0 ++ " times</span>" ++ openTopDecl
- where showBigNum n | n <= 9999 = show n
- | otherwise = case n `quotRem` 1000 of
- (q, r) -> showBigNum' q ++ "," ++ showWith r
- showBigNum' n | n <= 999 = show n
- | otherwise = case n `quotRem` 1000 of
- (q, r) -> showBigNum' q ++ "," ++ showWith r
- showWith n = padLeft 3 '0' $ show n
-
-
-
-closeTick :: String
-closeTick = "</span>"
-
-openTopDecl :: String
-openTopDecl = "<span class=\"decl\">"
-
-downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
-downToTopLevel ((_,TopLevelDecl {}):_) = []
-downToTopLevel (o : os) = o : downToTopLevel os
-downToTopLevel [] = []
-
-
--- build in logic for nesting bin boxes
-
-allowNesting :: Markup -- innermost
- -> Markup -- outermost
- -> Bool
-allowNesting n m | n == m = False -- no need to double nest
-allowNesting IsTicked TickedOnlyFalse = False
-allowNesting IsTicked TickedOnlyTrue = False
-allowNesting _ _ = True
-
-------------------------------------------------------------------------------
-
-data ModuleSummary = ModuleSummary
- { expTicked :: !Int
- , expTotal :: !Int
- , topFunTicked :: !Int
- , topFunTotal :: !Int
- , altTicked :: !Int
- , altTotal :: !Int
- }
- deriving (Show)
-
-
-showModuleSummary :: (String, String, ModuleSummary) -> String
-showModuleSummary (modName,fileName,modSummary) =
- "<tr>\n" ++
- "<td> <tt>module <a href=\"" ++ fileName ++ "\">"
- ++ modName ++ "</a></tt></td>\n" ++
- showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
- showSummary (altTicked modSummary) (altTotal modSummary) ++
- showSummary (expTicked modSummary) (expTotal modSummary) ++
- "</tr>\n"
-
-showTotalSummary :: ModuleSummary -> String
-showTotalSummary modSummary =
- "<tr style=\"background: #e0e0e0\">\n" ++
- "<th align=left> Program Coverage Total</tt></th>\n" ++
- showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
- showSummary (altTicked modSummary) (altTotal modSummary) ++
- showSummary (expTicked modSummary) (expTotal modSummary) ++
- "</tr>\n"
-
-showSummary :: (Integral t, Show t) => t -> t -> String
-showSummary ticked total =
- "<td align=\"right\">" ++ showP (percent ticked total) ++ "</td>" ++
- "<td>" ++ show ticked ++ "/" ++ show total ++ "</td>" ++
- "<td width=100>" ++
- (case percent ticked total of
- Nothing -> " "
- Just w -> bar w "bar"
- ) ++ "</td>"
- where
- showP Nothing = "- "
- showP (Just x) = show x ++ "%"
- bar 0 _ = bar 100 "invbar"
- bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
- "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
- "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
- "</table></td></tr></table>"
-
-percent :: (Integral a) => a -> a -> Maybe a
-percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
-
-instance Semi.Semigroup ModuleSummary where
- (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) <> (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
- = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
-
-instance Monoid ModuleSummary where
- mempty = ModuleSummary
- { expTicked = 0
- , expTotal = 0
- , topFunTicked = 0
- , topFunTotal = 0
- , altTicked = 0
- , altTotal = 0
- }
- mappend = (<>)
-
-------------------------------------------------------------------------------
--- global color palette
-
-red,green,yellow :: String
-red = "#f20913"
-green = "#60de51"
-yellow = "yellow"
=====================================
utils/hpc/HpcOverlay.hs deleted
=====================================
@@ -1,157 +0,0 @@
-module HpcOverlay where
-
-import HpcFlags
-import HpcParser
-import HpcUtils
-import Trace.Hpc.Tix
-import Trace.Hpc.Mix
-import Trace.Hpc.Util
-import qualified Data.Map as Map
-import Data.Tree
-
-overlay_options :: FlagOptSeq
-overlay_options
- = srcDirOpt
- . hpcDirOpt
- . resetHpcDirsOpt
- . outputOpt
- . verbosityOpt
-
-overlay_plugin :: Plugin
-overlay_plugin = Plugin { name = "overlay"
- , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]"
- , options = overlay_options
- , summary = "Generate a .tix file from an overlay file"
- , implementation = overlay_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-overlay_main :: Flags -> [String] -> IO ()
-overlay_main _ [] = hpcError overlay_plugin $ "no overlay file specified"
-overlay_main flags files = do
- specs <- mapM hpcParser files
- let (Spec globals modules) = concatSpec specs
-
- let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
-
- mod_info <-
- sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu)
- content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
- processModule modu content mix mod_spec globals
- | (modu, mod_spec) <- Map.toList modules1
- ]
-
-
- let tix = Tix $ mod_info
-
- case outputFile flags of
- "-" -> putStrLn (show tix)
- out -> writeFile out (show tix)
-
-
-processModule :: String -- ^ module name
- -> String -- ^ module contents
- -> Mix -- ^ mix entry for this module
- -> [Tick] -- ^ local ticks
- -> [ExprTick] -- ^ global ticks
- -> IO TixModule
-processModule modName modContents (Mix _ _ hash _ entries) locals globals = do
-
- let hsMap :: Map.Map Int String
- hsMap = Map.fromList (zip [1..] $ lines modContents)
-
- let topLevelFunctions =
- Map.fromListWith (++)
- [ (nm,[pos])
- | (pos,TopLevelBox [nm]) <- entries
- ]
-
- let inside :: HpcPos -> String -> Bool
- inside pos nm =
- case Map.lookup nm topLevelFunctions of
- Nothing -> False
- Just poss -> any (pos `insideHpcPos`) poss
-
- -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick
- let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool
- plzTick pos (ExpBox _) (TickExpression _ match q _) =
- qualifier pos q
- && case match of
- Nothing -> True
- Just str -> str == grabHpcPos hsMap pos
- plzTick _ _ _ = False
-
-
- plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool
- plzTopTick pos label (ExprTick ignore) = plzTick pos label ignore
- plzTopTick pos _ (TickFunction fn q _) =
- qualifier pos q && pos `inside` fn
- plzTopTick pos label (InsideFunction fn igs) =
- pos `inside` fn && any (plzTopTick pos label) igs
-
-
- let tixs = Map.fromList
- [ (ix,
- any (plzTick pos label) globals
- || any (plzTopTick pos label) locals)
- | (ix,(pos,label)) <- zip [0..] entries
- ]
-
-
- -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span)
-
- let forest = createMixEntryDom
- [ (srcspan,ix)
- | ((srcspan,_),ix) <- zip entries [0..]
- ]
-
-
- --
- let forest2 = addParentToList [] $ forest
--- putStrLn $ drawForest $ map (fmap show') $ forest2
-
- let isDomList = Map.fromList
- [ (ix,filter (/= ix) rng ++ dom)
- | (_,(rng,dom)) <- concatMap flatten forest2
- , ix <- rng
- ]
-
- -- We do not use laziness here, because the dominator lists
- -- point to their equivent peers, creating loops.
-
-
- let isTicked n =
- case Map.lookup n tixs of
- Just v -> v
- Nothing -> error $ "can not find ix # " ++ show n
-
- let tixs' = [ case Map.lookup n isDomList of
- Just vs -> if any isTicked (n : vs) then 1 else 0
- Nothing -> error $ "can not find ix in dom list # " ++ show n
- | n <- [0..(length entries - 1)]
- ]
-
- return $ TixModule modName hash (length tixs') tixs'
-
-qualifier :: HpcPos -> Maybe Qualifier -> Bool
-qualifier _ Nothing = True
-qualifier pos (Just (OnLine n)) = n == l1 && n == l2
- where (l1,_,l2,_) = fromHpcPos pos
-qualifier pos (Just (AtPosition l1' c1' l2' c2'))
- = (l1', c1', l2', c2') == fromHpcPos pos
-
-concatSpec :: [Spec] -> Spec
-concatSpec = foldr
- (\ (Spec pre1 body1) (Spec pre2 body2)
- -> Spec (pre1 ++ pre2) (body1 ++ body2))
- (Spec [] [])
-
-
-
-addParentToTree :: [a] -> MixEntryDom [a] -> MixEntryDom ([a],[a])
-addParentToTree path (Node (pos,a) children) =
- Node (pos,(a,path)) (addParentToList (a ++ path) children)
-
-addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])]
-addParentToList path nodes = map (addParentToTree path) nodes
=====================================
utils/hpc/HpcParser.y deleted
=====================================
@@ -1,106 +0,0 @@
-{
-module HpcParser where
-
-import HpcLexer
-}
-
-%name parser
-%expect 0
-%tokentype { Token }
-
-%token
- MODULE { ID "module" }
- TICK { ID "tick" }
- EXPRESSION { ID "expression" }
- ON { ID "on" }
- LINE { ID "line" }
- POSITION { ID "position" }
- FUNCTION { ID "function" }
- INSIDE { ID "inside" }
- AT { ID "at" }
- ':' { SYM ':' }
- '-' { SYM '-' }
- ';' { SYM ';' }
- '{' { SYM '{' }
- '}' { SYM '}' }
- int { INT $$ }
- string { STR $$ }
- cat { CAT $$ }
-%%
-
-Spec :: { Spec }
-Spec : Ticks Modules { Spec ($1 []) ($2 []) }
-
-Modules :: { L (ModuleName,[Tick]) }
-Modules : Modules Module { $1 . ((:) $2) }
- | { id }
-
-Module :: { (ModuleName,[Tick]) }
-Module : MODULE string '{' TopTicks '}'
- { ($2,$4 []) }
-
-TopTicks :: { L Tick }
-TopTicks : TopTicks TopTick { $1 . ((:) $2) }
- | { id }
-
-TopTick :: { Tick }
-TopTick : Tick { ExprTick $1 }
- | TICK FUNCTION string optQual optCat ';'
- { TickFunction $3 $4 $5 }
- | INSIDE string '{' TopTicks '}'
- { InsideFunction $2 ($4 []) }
-
-Ticks :: { L ExprTick }
-Ticks : Ticks Tick { $1 . ((:) $2) }
- | { id }
-
-Tick :: { ExprTick }
-Tick : TICK optString optQual optCat ';'
- { TickExpression False $2 $3 $4 }
-
-optString :: { Maybe String }
-optString : string { Just $1 }
- | { Nothing }
-
-optQual :: { Maybe Qualifier }
-optQual : ON LINE int { Just (OnLine $3) }
- | AT POSITION int ':' int '-' int ':' int
- { Just (AtPosition $3 $5 $7 $9) }
- | { Nothing }
-optCat :: { Maybe String }
-optCat : cat { Just $1 }
- | { Nothing }
-
-{
-type L a = [a] -> [a]
-
-type ModuleName = String
-
-data Spec
- = Spec [ExprTick] [(ModuleName,[Tick])]
- deriving (Show)
-
-data ExprTick
- = TickExpression Bool (Maybe String) (Maybe Qualifier) (Maybe String)
- deriving (Show)
-
-data Tick
- = ExprTick ExprTick
- | TickFunction String (Maybe Qualifier) (Maybe String)
- | InsideFunction String [Tick]
- deriving (Show)
-
-data Qualifier = OnLine Int
- | AtPosition Int Int Int Int
- deriving (Show)
-
-
-
-hpcParser :: String -> IO Spec
-hpcParser filename = do
- txt <- readFile filename
- let tokens = initLexer txt
- return $ parser tokens
-
-happyError e = error $ show (take 10 e)
-}
=====================================
utils/hpc/HpcReport.hs deleted
=====================================
@@ -1,277 +0,0 @@
----------------------------------------------------------
--- The main program for the hpc-report tool, part of HPC.
--- Colin Runciman and Andy Gill, June 2006
----------------------------------------------------------
-
-module HpcReport (report_plugin) where
-
-import Prelude hiding (exp)
-import Data.List(sort,intersperse,sortBy)
-import HpcFlags
-import Trace.Hpc.Mix
-import Trace.Hpc.Tix
-import Control.Monad hiding (guard)
-import qualified Data.Set as Set
-
-notExpecting :: String -> a
-notExpecting s = error ("not expecting "++s)
-
-data BoxTixCounts = BT {boxCount, tixCount :: !Int}
-
-btZero :: BoxTixCounts
-btZero = BT {boxCount=0, tixCount=0}
-
-btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
-btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)
-
-btPercentage :: String -> BoxTixCounts -> String
-btPercentage s (BT b t) = showPercentage s t b
-
-showPercentage :: String -> Int -> Int -> String
-showPercentage s 0 0 = "100% "++s++" (0/0)"
-showPercentage s n d = showWidth 3 p++"% "++
- s++
- " ("++show n++"/"++show d++")"
- where
- p = (n*100) `div` d
- showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx
- where
- sx = show x0
- shortOf x y = if y < x then x-y else 0
-
-data BinBoxTixCounts = BBT { binBoxCount
- , onlyTrueTixCount
- , onlyFalseTixCount
- , bothTixCount :: !Int}
-
-bbtzero :: BinBoxTixCounts
-bbtzero = BBT { binBoxCount=0
- , onlyTrueTixCount=0
- , onlyFalseTixCount=0
- , bothTixCount=0}
-
-bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts
-bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) =
- BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2)
-
-bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String
-bbtPercentage s withdetail (BBT b tt ft bt) =
- showPercentage s bt b ++
- if withdetail && bt/=b then
- detailFor tt "always True"++
- detailFor ft "always False"++
- detailFor (b-(tt+ft+bt)) "unevaluated"
- else ""
- where
- detailFor n txt = if n>0 then ", "++show n++" "++txt
- else ""
-
-data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
- , guard,cond,qual :: !BinBoxTixCounts
- , decPaths :: [[String]]}
-
-miZero :: ModInfo
-miZero = MI { exp=btZero
- , alt=btZero
- , top=btZero
- , loc=btZero
- , guard=bbtzero
- , cond=bbtzero
- , qual=bbtzero
- , decPaths = []}
-
-miPlus :: ModInfo -> ModInfo -> ModInfo
-miPlus mi1 mi2 =
- MI { exp = exp mi1 `btPlus` exp mi2
- , alt = alt mi1 `btPlus` alt mi2
- , top = top mi1 `btPlus` top mi2
- , loc = loc mi1 `btPlus` loc mi2
- , guard = guard mi1 `bbtPlus` guard mi2
- , cond = cond mi1 `bbtPlus` cond mi2
- , qual = qual mi1 `bbtPlus` qual mi2
- , decPaths = decPaths mi1 ++ decPaths mi2 }
-
-allBinCounts :: ModInfo -> BinBoxTixCounts
-allBinCounts mi =
- BBT { binBoxCount = sumAll binBoxCount
- , onlyTrueTixCount = sumAll onlyTrueTixCount
- , onlyFalseTixCount = sumAll onlyFalseTixCount
- , bothTixCount = sumAll bothTixCount }
- where
- sumAll f = f (guard mi) + f (cond mi) + f (qual mi)
-
-accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
-accumCounts [] mi = mi
-accumCounts ((bl,btc):etc) mi
- | single bl = accumCounts etc mi'
- where
- mi' = case bl of
- ExpBox False -> mi{exp = inc (exp mi)}
- ExpBox True -> mi{exp = inc (exp mi), alt = inc (alt mi)}
- TopLevelBox dp -> mi{top = inc (top mi)
- ,decPaths = upd dp (decPaths mi)}
- LocalBox dp -> mi{loc = inc (loc mi)
- ,decPaths = upd dp (decPaths mi)}
- _other -> notExpecting "BoxLabel in accumcounts"
- inc (BT {boxCount=bc,tixCount=tc}) =
- BT { boxCount = bc+1
- , tixCount = tc + bit (btc>0) }
- upd dp dps =
- if btc>0 then dps else dp:dps
-accumCounts [_] _ = error "accumCounts: Unhandled case: [_] _"
-accumCounts ((bl0,btc0):(bl1,btc1):etc) mi =
- accumCounts etc mi'
- where
- mi' = case (bl0,bl1) of
- (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
- mi{guard = inc (guard mi)}
- (BinBox CondBinBox True, BinBox CondBinBox False) ->
- mi{cond = inc (cond mi)}
- (BinBox QualBinBox True, BinBox QualBinBox False) ->
- mi{qual = inc (qual mi)}
- _other -> notExpecting "BoxLabel pair in accumcounts"
- inc (BBT { binBoxCount=bbc
- , onlyTrueTixCount=ttc
- , onlyFalseTixCount=ftc
- , bothTixCount=btc}) =
- BBT { binBoxCount = bbc+1
- , onlyTrueTixCount = ttc + bit (btc0 >0 && btc1==0)
- , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
- , bothTixCount = btc + bit (btc0 >0 && btc1 >0) }
-
-bit :: Bool -> Int
-bit True = 1
-bit False = 0
-
-single :: BoxLabel -> Bool
-single (ExpBox {}) = True
-single (TopLevelBox _) = True
-single (LocalBox _) = True
-single (BinBox {}) = False
-
-modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
-modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
- Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
- return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
- where
- q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
- else mi
-
-modReport :: Flags -> TixModule -> IO ()
-modReport hpcflags tix@(TixModule moduleName _ _ _) = do
- mi <- modInfo hpcflags False tix
- if xmlOutput hpcflags
- then putStrLn $ " <module name = " ++ show moduleName ++ ">"
- else putStrLn ("-----<module "++moduleName++">-----")
- printModInfo hpcflags mi
- if xmlOutput hpcflags
- then putStrLn $ " </module>"
- else return ()
-
-printModInfo :: Flags -> ModInfo -> IO ()
-printModInfo hpcflags mi | xmlOutput hpcflags = do
- element "exprs" (xmlBT $ exp mi)
- element "booleans" (xmlBBT $ allBinCounts mi)
- element "guards" (xmlBBT $ guard mi)
- element "conditionals" (xmlBBT $ cond mi)
- element "qualifiers" (xmlBBT $ qual mi)
- element "alts" (xmlBT $ alt mi)
- element "local" (xmlBT $ loc mi)
- element "toplevel" (xmlBT $ top mi)
-printModInfo hpcflags mi = do
- putStrLn (btPercentage "expressions used" (exp mi))
- putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
- putStrLn (" "++bbtPercentage "guards" True (guard mi))
- putStrLn (" "++bbtPercentage "'if' conditions" True (cond mi))
- putStrLn (" "++bbtPercentage "qualifiers" True (qual mi))
- putStrLn (btPercentage "alternatives used" (alt mi))
- putStrLn (btPercentage "local declarations used" (loc mi))
- putStrLn (btPercentage "top-level declarations used" (top mi))
- modDecList hpcflags mi
-
-modDecList :: Flags -> ModInfo -> IO ()
-modDecList hpcflags mi0 =
- when (decList hpcflags && someDecsUnused mi0) $ do
- putStrLn "unused declarations:"
- mapM_ showDecPath (sort (decPaths mi0))
- where
- someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
- tixCount (loc mi) < boxCount (loc mi)
- showDecPath dp = putStrLn (" "++
- concat (intersperse "." dp))
-
-report_plugin :: Plugin
-report_plugin = Plugin { name = "report"
- , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
- , options = report_options
- , summary = "Output textual report about program coverage"
- , implementation = report_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-report_main :: Flags -> [String] -> IO ()
-report_main hpcflags (progName:mods) = do
- let hpcflags1 = hpcflags
- { includeMods = Set.fromList mods
- `Set.union`
- includeMods hpcflags }
- let prog = getTixFileName $ progName
- tix <- readTix prog
- case tix of
- Just (Tix tickCounts) ->
- makeReport hpcflags1 progName
- $ sortBy (\ mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2)
- $ [ tix'
- | tix'@(TixModule m _ _ _) <- tickCounts
- , allowModule hpcflags1 m
- ]
- Nothing -> hpcError report_plugin $ "unable to find tix file for:" ++ progName
-report_main _ [] =
- hpcError report_plugin $ "no .tix file or executable name specified"
-
-makeReport :: Flags -> String -> [TixModule] -> IO ()
-makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
- putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
- putStrLn $ "<coverage name=" ++ show progName ++ ">"
- if perModule hpcflags
- then mapM_ (modReport hpcflags) modTcs
- else return ()
- mis <- mapM (modInfo hpcflags True) modTcs
- putStrLn $ " <summary>"
- printModInfo hpcflags (foldr miPlus miZero mis)
- putStrLn $ " </summary>"
- putStrLn $ "</coverage>"
-makeReport hpcflags _ modTcs =
- if perModule hpcflags then
- mapM_ (modReport hpcflags) modTcs
- else do
- mis <- mapM (modInfo hpcflags True) modTcs
- printModInfo hpcflags (foldr miPlus miZero mis)
-
-element :: String -> [(String,String)] -> IO ()
-element tag attrs = putStrLn $
- " <" ++ tag ++ " "
- ++ unwords [ x ++ "=" ++ show y
- | (x,y) <- attrs
- ] ++ "/>"
-
-xmlBT :: BoxTixCounts -> [(String, String)]
-xmlBT (BT b t) = [("boxes",show b),("count",show t)]
-
-xmlBBT :: BinBoxTixCounts -> [(String, String)]
-xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]
-
-------------------------------------------------------------------------------
-
-report_options :: FlagOptSeq
-report_options
- = perModuleOpt
- . decListOpt
- . excludeOpt
- . includeOpt
- . srcDirOpt
- . hpcDirOpt
- . resetHpcDirsOpt
- . xmlOutputOpt
- . verbosityOpt
=====================================
utils/hpc/HpcShowTix.hs deleted
=====================================
@@ -1,63 +0,0 @@
-module HpcShowTix (showtix_plugin) where
-
-import Trace.Hpc.Mix
-import Trace.Hpc.Tix
-
-import HpcFlags
-
-import qualified Data.Set as Set
-
-showtix_options :: FlagOptSeq
-showtix_options
- = excludeOpt
- . includeOpt
- . srcDirOpt
- . hpcDirOpt
- . resetHpcDirsOpt
- . outputOpt
- . verbosityOpt
-
-showtix_plugin :: Plugin
-showtix_plugin = Plugin { name = "show"
- , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
- , options = showtix_options
- , summary = "Show .tix file in readable, verbose format"
- , implementation = showtix_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-
-showtix_main :: Flags -> [String] -> IO ()
-showtix_main _ [] = hpcError showtix_plugin $ "no .tix file or executable name specified"
-showtix_main flags (prog:modNames) = do
- let hpcflags1 = flags
- { includeMods = Set.fromList modNames
- `Set.union`
- includeMods flags }
-
- optTixs <- readTix (getTixFileName prog)
- case optTixs of
- Nothing -> hpcError showtix_plugin $ "could not read .tix file : " ++ prog
- Just (Tix tixs) -> do
- tixs_mixs <- sequence
- [ do mix <- readMixWithFlags hpcflags1 (Right tix)
- return $ (tix,mix)
- | tix <- tixs
- , allowModule hpcflags1 (tixModuleName tix)
- ]
-
- let rjust n str = take (n - length str) (repeat ' ') ++ str
- let ljust n str = str ++ take (n - length str) (repeat ' ')
-
- sequence_ [ sequence_ [ putStrLn (rjust 5 (show ix) ++ " " ++
- rjust 10 (show count) ++ " " ++
- ljust 20 modName ++ " " ++ rjust 20 (show pos) ++ " " ++ show lab)
- | (count,ix,(pos,lab)) <- zip3 tixs' [(0::Int)..] entries
- ]
- | ( TixModule modName _hash1 _ tixs'
- , Mix _file _timestamp _hash2 _tab entries
- ) <- tixs_mixs
- ]
-
- return ()
=====================================
utils/hpc/HpcUtils.hs deleted
=====================================
@@ -1,37 +0,0 @@
-module HpcUtils where
-
-import Trace.Hpc.Util (catchIO, HpcPos, fromHpcPos, readFileUtf8)
-import qualified Data.Map as Map
-import System.FilePath
-
-dropWhileEndLE :: (a -> Bool) -> [a] -> [a]
--- Spec: dropWhileEndLE p = reverse . dropWhile p . reverse
-dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []
-
--- turns \n into ' '
--- | grab's the text behind a HpcPos;
-grabHpcPos :: Map.Map Int String -> HpcPos -> String
-grabHpcPos hsMap srcspan =
- case lns of
- [] -> error "grabHpcPos: invalid source span"
- [ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln)
- hd : tl ->
- let lns1 = drop (c1 -1) hd : tl
- lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ]
- in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2
- where (l1,c1,l2,c2) = fromHpcPos srcspan
- lns = map (\ n -> case Map.lookup n hsMap of
- Just ln -> ln
- Nothing -> error $ "bad line number : " ++ show n
- ) [l1..l2]
-
-
-readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String
-readFileFromPath _ filename@('/':_) _ = readFileUtf8 filename
-readFileFromPath err filename path0 = readTheFile path0
- where
- readTheFile [] = err $ "could not find " ++ show filename
- ++ " in path " ++ show path0
- readTheFile (dir:dirs) =
- catchIO (readFileUtf8 (dir </> filename))
- (\ _ -> readTheFile dirs)
=====================================
utils/hpc/Main.hs deleted
=====================================
@@ -1,217 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables, TupleSections #-}
--- (c) 2007 Andy Gill
-
--- Main driver for Hpc
-import Control.Monad (forM, forM_, when)
-import Data.Bifunctor (bimap)
-import Data.List (intercalate, partition, uncons)
-import Data.List.NonEmpty (NonEmpty((:|)))
-import Data.Maybe (catMaybes, isJust)
-import Data.Version
-import System.Environment
-import System.Exit
-import System.Console.GetOpt
-import System.Directory (doesPathExist)
-
-import HpcFlags
-import HpcReport
-import HpcMarkup
-import HpcCombine
-import HpcShowTix
-import HpcDraft
-import HpcOverlay
-import Paths_hpc_bin
-
-helpList :: IO ()
-helpList = do
- putStrLn $
- "Usage: hpc COMMAND ...\n\n" ++
- section "Commands" help ++
- section "Reporting Coverage" reporting ++
- section "Processing Coverage files" processing ++
- section "Coverage Overlays" overlays ++
- section "Others" other ++
- ""
- putStrLn ""
- putStrLn "or: hpc @response_file_1 @response_file_2 ..."
- putStrLn ""
- putStrLn "The contents of a Response File must have this format:"
- putStrLn "COMMAND ..."
- putStrLn ""
- putStrLn "example:"
- putStrLn "report my_library.tix --include=ModuleA \\"
- putStrLn "--include=ModuleB"
- where
- help = ["help"]
- reporting = ["report","markup"]
- overlays = ["overlay","draft"]
- processing = ["sum","combine","map"]
- other = [ name hook
- | hook <- hooks
- , name hook `notElem`
- (concat [help,reporting,processing,overlays])
- ]
-
-section :: String -> [String] -> String
-section _ [] = ""
-section msg cmds = msg ++ ":\n"
- ++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook
- | cmd <- cmds
- , hook <- hooks
- , name hook == cmd
- ]
-
-dispatch :: [String] -> IO ()
-dispatch [] = do
- helpList
- exitWith ExitSuccess
-dispatch (txt:args0) = do
- case lookup txt hooks' of
- Just plugin -> parse plugin args0
- _ -> case getResponseFileName txt of
- Nothing -> parse help_plugin (txt:args0)
- Just firstResponseFileName -> do
- let
- (responseFileNames', nonResponseFileNames) = partitionFileNames args0
- -- if arguments are combination of Response Files and non-Response Files, exit with error
- when (length nonResponseFileNames > 0) $ do
- let
- putStrLn $ "First argument '" <> txt <> "' is a Response File, " <>
- "followed by non-Response File(s): '" <> intercalate "', '" nonResponseFileNames <> "'"
- putStrLn $ "When first argument is a Response File, " <>
- "all arguments should be Response Files."
- exitFailure
- let
- responseFileNames :: NonEmpty FilePath
- responseFileNames = firstResponseFileName :| responseFileNames'
-
- forM_ responseFileNames $ \responseFileName -> do
- exists <- doesPathExist responseFileName
- when (not exists) $ do
- putStrLn $ "Response File '" <> responseFileName <> "' does not exist"
- exitFailure
-
- -- read all Response Files
- responseFileNamesAndText :: NonEmpty (FilePath, String) <-
- forM responseFileNames $ \responseFileName ->
- fmap (responseFileName, ) (readFile responseFileName)
- forM_ responseFileNamesAndText $ \(responseFileName, responseFileText) ->
- -- parse first word of Response File, which should be a command
- case uncons $ words responseFileText of
- Nothing -> do
- putStrLn $ "Response File '" <> responseFileName <> "' has no command"
- exitFailure
- Just (responseFileCommand, args1) -> case lookup responseFileCommand hooks' of
- -- check command for validity
- -- It is important than a Response File cannot specify another Response File;
- -- this is prevented
- Nothing -> do
- putStrLn $ "Response File '" <> responseFileName <>
- "' command '" <> responseFileCommand <> "' invalid"
- exitFailure
- Just plugin -> do
- putStrLn $ "Response File '" <> responseFileName <> "':"
- parse plugin args1
-
- where
- getResponseFileName :: String -> Maybe FilePath
- getResponseFileName s = do
- (firstChar, filename) <- uncons s
- if firstChar == '@'
- then pure filename
- else Nothing
-
- -- first member of tuple is list of Response File names,
- -- second member of tuple is list of all other arguments
- partitionFileNames :: [String] -> ([FilePath], [String])
- partitionFileNames xs = let
- hasFileName :: [(String, Maybe FilePath)]
- hasFileName = fmap (\x -> (x, getResponseFileName x)) xs
- (fileNames, nonFileNames) :: ([Maybe FilePath], [String]) =
- bimap (fmap snd) (fmap fst) $ partition (isJust . snd) hasFileName
- in (catMaybes fileNames, nonFileNames)
-
- parse plugin args =
- case getOpt Permute (options plugin []) args of
- (_,_,errs) | not (null errs)
- -> do putStrLn "hpc failed:"
- sequence_ [ putStr (" " ++ err)
- | err <- errs
- ]
- putStrLn $ "\n"
- command_usage plugin
- exitFailure
- (o,ns,_) -> do
- let flags = final_flags plugin
- . foldr (.) id o
- $ init_flags plugin
- implementation plugin flags ns
-
-main :: IO ()
-main = do
- args <- getArgs
- dispatch args
-
-------------------------------------------------------------------------------
-
-hooks :: [Plugin]
-hooks = [ help_plugin
- , report_plugin
- , markup_plugin
- , sum_plugin
- , combine_plugin
- , map_plugin
- , showtix_plugin
- , overlay_plugin
- , draft_plugin
- , version_plugin
- ]
-
-hooks' :: [(String, Plugin)]
-hooks' = [ (name hook,hook) | hook <- hooks ]
-
-------------------------------------------------------------------------------
-
-help_plugin :: Plugin
-help_plugin = Plugin { name = "help"
- , usage = "[<HPC_COMMAND>]"
- , summary = "Display help for hpc or a single command"
- , options = help_options
- , implementation = help_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-help_main :: Flags -> [String] -> IO ()
-help_main _ [] = do
- helpList
- exitWith ExitSuccess
-help_main _ (sub_txt:_) = do
- case lookup sub_txt hooks' of
- Nothing -> do
- putStrLn $ "no such HPC command: " <> sub_txt
- exitFailure
- Just plugin' -> do
- command_usage plugin'
- exitWith ExitSuccess
-
-help_options :: FlagOptSeq
-help_options = id
-
-------------------------------------------------------------------------------
-
-version_plugin :: Plugin
-version_plugin = Plugin { name = "version"
- , usage = ""
- , summary = "Display version for hpc"
- , options = id
- , implementation = version_main
- , init_flags = default_flags
- , final_flags = default_final_flags
- }
-
-version_main :: Flags -> [String] -> IO ()
-version_main _ _ = putStrLn ("hpc tools, version " ++ showVersion version)
-
-
-------------------------------------------------------------------------------
=====================================
utils/hpc/Makefile deleted
=====================================
@@ -1,15 +0,0 @@
-# -----------------------------------------------------------------------------
-#
-# (c) 2009 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
-#
-# -----------------------------------------------------------------------------
-
-dir = utils/hpc
-TOP = ../..
-include $(TOP)/mk/sub-makefile.mk
=====================================
utils/hpc/hpc-bin.cabal deleted
=====================================
@@ -1,44 +0,0 @@
-Name: hpc-bin
--- XXX version number:
-Version: 0.68
-Copyright: XXX
-License: BSD3
--- XXX License-File: LICENSE
-Author: XXX
-Maintainer: XXX
-Synopsis: XXX
-Description: XXX
-Category: Development
-build-type: Simple
-cabal-version: 2.0
-
-Flag build-tool-depends
- Description: Use build-tool-depends
- Default: True
-
-Executable hpc
- Default-Language: Haskell2010
- Main-Is: Main.hs
- Other-Modules: HpcParser
- HpcCombine
- HpcDraft
- HpcFlags
- HpcLexer
- HpcMarkup
- HpcOverlay
- HpcReport
- HpcShowTix
- HpcUtils
- Paths_hpc_bin
-
- autogen-modules: Paths_hpc_bin
-
- Build-Depends: base >= 4 && < 5,
- directory >= 1 && < 1.4,
- filepath >= 1 && < 1.5,
- containers >= 0.1 && < 0.7,
- array >= 0.1 && < 0.6,
- hpc >= 0.6.1 && < 0.7
-
- if flag(build-tool-depends)
- build-tool-depends: happy:happy >= 1.20.0
=====================================
utils/hpc/hpc.wrapper deleted
=====================================
@@ -1,2 +0,0 @@
-#!/bin/sh
-exec "$executablename" ${1+"$@"}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cacd04265bc8a210f0c1ff5ee156b937bbfcd26...b140966379c6938dea3e53b39f0783517cb17bff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cacd04265bc8a210f0c1ff5ee156b937bbfcd26...b140966379c6938dea3e53b39f0783517cb17bff
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230308/a39c0058/attachment-0001.html>
More information about the ghc-commits
mailing list