Florian Ragwitz pushed to branch wip/rafl/hpc-viewpatterns at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • changelog.d/hpc-viewpats
    1 
    +section: compiler
    2 
    +synopsis: Support coverage reporting for view patterns
    3 
    +issues: #18590
    4 
    +mrs: !16805
    5 
    +description:
    6 
    +  Coverage reporting (:ghc-flag:`-fhpc`) now traverses into patterns and
    7 
    +  creates ticks for expressions contained within :extension:`ViewPatterns`.
    8 
    +
    9 
    +  This provides normal coverage semantics for those embedded expressions,
    10 
    +  which were previously entirely ignored in coverage reporting.
    11 
    +
    12 
    +  Since tick insertion is shared by coverage reporting, source notes,
    13 
    +  breakpoints, and profiling, this also allows those other modes to instrument
    14 
    +  expressions inside patterns where applicable.

  • compiler/GHC/HsToCore/Ticks.hs
    ... ... @@ -401,8 +401,9 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
    401 401 
       -- TODO: better name for rhs's for non-simple patterns?
    402 402 
       let name = maybe "(...)" getOccString simplePatId
    403 403
    404 
    +  lhs' <- addTickLPat lhs
    404 405 
       (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs
    405 
    -  let pat' = pat { pat_rhs = rhs'}
    406 
    +  let pat' = pat { pat_lhs = lhs', pat_rhs = rhs'}
    406 407
    407 408 
       -- Should create ticks here?
    408 409 
       density <- getDensity
    ... ... @@ -752,11 +753,12 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do
    752 753
    753 754 
     addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} ->  Match GhcTc (LHsExpr GhcTc)
    754 755 
                  -> TM (Match GhcTc (LHsExpr GhcTc))
    755 
    -addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats
    756 
    +addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L l pats
    756 757 
                                                            , m_grhss = gRHSs }) =
    757 758 
       bindLocals pats $ do
    759 
    +    pats' <- mapM addTickLPat pats
    758 760 
         gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs
    759 
    -    return $ match { m_grhss = gRHSs' }
    761 
    +    return $ match { m_pats = L l pats', m_grhss = gRHSs' }
    760 762
    761 763 
     addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
    762 764 
                  -> TM (GRHSs GhcTc (LHsExpr GhcTc))
    ... ... @@ -936,9 +938,60 @@ addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
    936 938 
             return $ syn { syn_expr = x' }
    937 939 
     addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
    938 940
    939 
    --- we do not walk into patterns.
    941 
    +-- ViewPat contains an LHsExpr, so we have to walk into patterns.
    940 942 
     addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
    941 
    -addTickLPat pat = return pat
    943 
    +addTickLPat = traverse addTickPat
    944 
    +
    945 
    +addTickPat :: Pat GhcTc -> TM (Pat GhcTc)
    946 
    +addTickPat (ViewPat x expr pat) =
    947 
    +  ViewPat x <$> addTickLHsExpr expr <*> addTickLPat pat
    948 
    +addTickPat (LazyPat x pat) = LazyPat x <$> addTickLPat pat
    949 
    +addTickPat (AsPat x var pat) = AsPat x var <$> addTickLPat pat
    950 
    +addTickPat (ParPat x pat) = ParPat x <$> addTickLPat pat
    951 
    +addTickPat (BangPat x pat) = BangPat x <$> addTickLPat pat
    952 
    +addTickPat (SigPat x pat sig) = SigPat x <$> addTickLPat pat <*> pure sig
    953 
    +addTickPat (ModifiedPat x mods pat) = ModifiedPat x mods <$> addTickLPat pat
    954 
    +addTickPat (ListPat x pats) = ListPat x <$> mapM addTickLPat pats
    955 
    +addTickPat (TuplePat x pats boxity) =
    956 
    +  TuplePat x <$> mapM addTickLPat pats <*> pure boxity
    957 
    +addTickPat (OrPat x pats) = OrPat x <$> mapM addTickLPat pats
    958 
    +addTickPat (SumPat x pat alt arity) =
    959 
    +  SumPat x <$> addTickLPat pat <*> pure alt <*> pure arity
    960 
    +addTickPat pat@ConPat{ pat_args } = do
    961 
    +  pat_args' <- addTickConPatDetails pat_args
    962 
    +  pure pat{ pat_args = pat_args' }
    963 
    +  where
    964 
    +    addTickConPatDetails :: HsConPatDetails GhcTc -> TM (HsConPatDetails GhcTc)
    965 
    +    addTickConPatDetails (PrefixCon x pats) =
    966 
    +      PrefixCon x <$> mapM addTickLPat pats
    967 
    +    addTickConPatDetails (InfixCon x pat1 pat2) =
    968 
    +      InfixCon x <$> addTickLPat pat1 <*> addTickLPat pat2
    969 
    +    addTickConPatDetails (RecCon x fields) =
    970 
    +      RecCon x <$> addTickRecFields fields
    971 
    +      where
    972 
    +        addTickRecFields flds@HsRecFields{ rec_flds } = do
    973 
    +          rec_flds' <- mapM (traverse addTickRecField) rec_flds
    974 
    +          pure flds{ rec_flds = rec_flds' }
    975 
    +        addTickRecField fld = do
    976 
    +          rhs' <- addTickLPat (hfbRHS fld)
    977 
    +          pure fld{ hfbRHS = rhs' }
    978 
    +addTickPat (NPat x lit neg eq) =
    979 
    +  NPat x lit <$> traverse (addTickSyntaxExpr hpcSrcSpan) neg
    980 
    +             <*> addTickSyntaxExpr hpcSrcSpan eq
    981 
    +addTickPat (NPlusKPat x n k lit ge minus) =
    982 
    +  NPlusKPat x n k lit <$> addTickSyntaxExpr hpcSrcSpan ge
    983 
    +                      <*> addTickSyntaxExpr hpcSrcSpan minus
    984 
    +addTickPat (XPat ext@CoPat{ co_pat_inner }) =
    985 
    +  XPat . (\pat -> ext{ co_pat_inner = pat }) <$> addTickPat co_pat_inner
    986 
    +addTickPat (XPat (ExpansionPat orig expansion)) =
    987 
    +  XPat . ExpansionPat orig <$> addTickPat expansion
    988 
    +addTickPat p@WildPat{} = pure p
    989 
    +addTickPat p@VarPat{} = pure p
    990 
    +addTickPat p@LitPat{} = pure p
    991 
    +addTickPat p@QualLitPat{} = pure p
    992 
    +addTickPat p@SplicePat{} = pure p
    993 
    +addTickPat p@EmbTyPat{} = pure p
    994 
    +addTickPat p@InvisPat{} = pure p
    942 995
    943 996 
     addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
    944 997 
     addTickHsCmdTop (HsCmdTop x cmd) =
    ... ... @@ -1012,10 +1065,11 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
    1012 1065 
       return $ mg { mg_alts = L l matches' }
    1013 1066
    1014 1067 
     addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
    1015 
    -addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) =
    1068 
    +addTickCmdMatch match@(Match { m_pats = L l pats, m_grhss = gRHSs }) =
    1016 1069 
       bindLocals pats $ do
    1070 
    +    pats' <- mapM addTickLPat pats
    1017 1071 
         gRHSs' <- addTickCmdGRHSs gRHSs
    1018 
    -    return $ match { m_grhss = gRHSs' }
    1072 
    +    return $ match { m_pats = L l pats', m_grhss = gRHSs' }
    1019 1073
    1020 1074 
     addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
    1021 1075 
     addTickCmdGRHSs (GRHSs x guarded local_binds) =

  • testsuite/tests/hpc/all.T
    ... ... @@ -7,6 +7,8 @@ test('T10138', [extra_files(['.keepme.hpc.T10138/']),
    7 7
    8 8 
     test('T11798', normal, makefile_test, [])
    9 9
    10 
    +test('viewpats', normal, compile_and_run, ['-fhpc'])
    11 
    +
    10 12 
     # Run tests below only for the hpc way.
    11 13 
     #
    12 14 
     # Do not explicitly specify '-fhpc' in extra_hc_opts, unless also setting

  • testsuite/tests/hpc/viewpats.hs
    1 
    +{-# LANGUAGE ViewPatterns, Modifiers, OrPatterns, UnboxedSums, NPlusKPatterns, TypeFamilies, OverloadedLists, QualifiedStrings, LambdaCase, Arrows #-}
    2 
    +
    3 
    +module Main where
    4 
    +
    5 
    +import Control.Exception
    6 
    +import Data.List
    7 
    +import Data.Tree
    8 
    +import Trace.Hpc.Mix
    9 
    +import Trace.Hpc.Reflect
    10 
    +import Trace.Hpc.Tix
    11 
    +import Trace.Hpc.Util
    12 
    +import qualified Data.String as S
    13 
    +import Control.Arrow
    14 
    +
    15 
    +testView :: Int -> Bool
    16 
    +testView (id -> 1) = True
    17 
    +testView _ = False
    18 
    +
    19 
    +testLazyForced :: Int -> Int
    20 
    +testLazyForced ~(id -> x) = x + 1
    21 
    +
    22 
    +testLazyUnforced :: Int -> Int
    23 
    +testLazyUnforced ~(id -> x) = 42
    24 
    +
    25 
    +testAsCovered :: Int -> Int
    26 
    +testAsCovered x@(id -> y) = x + y
    27 
    +
    28 
    +testAsUncovered :: Int -> Int
    29 
    +testAsUncovered ~(_x@(id -> _y)) = 42
    30 
    +
    31 
    +testBangCovered :: Int -> Int
    32 
    +testBangCovered !(id -> x) = x + 1
    33 
    +
    34 
    +testBangUncovered :: Int -> Int
    35 
    +testBangUncovered ~(!(id -> x)) = 42
    36 
    +
    37 
    +testSigCovered :: Int -> Int
    38 
    +testSigCovered ((id -> x) :: Int) = x + 1
    39 
    +
    40 
    +testSigUncovered :: Int -> Int
    41 
    +testSigUncovered ((id -> x) :: Int) = 42
    42 
    +
    43 
    +testModifiedCovered :: Int -> Int
    44 
    +testModifiedCovered (%() (id -> x)) = x + 1
    45 
    +
    46 
    +testModifiedUncovered :: Int -> Int
    47 
    +testModifiedUncovered (%() (id -> x)) = 42
    48 
    +
    49 
    +testList :: [Int] -> Int
    50 
    +testList [id -> x] = x + 1
    51 
    +testList [] = 42
    52 
    +
    53 
    +testTuple :: (Int, Int) -> Int
    54 
    +testTuple (id -> x, id -> _y) = x + 1
    55 
    +
    56 
    +testOr :: [Int] -> Bool
    57 
    +testOr (id -> []; reverse -> [_]) = True
    58 
    +testOr _ = False
    59 
    +
    60 
    +testSum :: (# Int | Int #) -> Int
    61 
    +testSum (# (id -> x) | #) = x + 1
    62 
    +testSum (# | (id -> y) #) = y + 2
    63 
    +
    64 
    +testNPat :: Int -> Int
    65 
    +testNPat 1 = 10
    66 
    +testNPat (-1) = 20
    67 
    +testNPat _ = 30
    68 
    +
    69 
    +testNPlusKPat :: Int -> Int
    70 
    +testNPlusKPat (n+3) = n * 2
    71 
    +testNPlusKPat _ = 0
    72 
    +
    73 
    +type family CoList a where
    74 
    +  CoList Bool = [Int]
    75 
    +
    76 
    +testCoPat :: CoList Bool -> Int
    77 
    +testCoPat [id -> x] = x + 1
    78 
    +testCoPat [] = 0
    79 
    +
    80 
    +testQualifiedString :: String -> Int
    81 
    +testQualifiedString S."hello" = 1
    82 
    +testQualifiedString _ = 0
    83 
    +
    84 
    +testPrefix :: Maybe Int -> Int
    85 
    +testPrefix (Just (id -> x)) = x + 1
    86 
    +testPrefix _ = 0
    87 
    +
    88 
    +testInfix :: [Int] -> Int
    89 
    +testInfix ((id -> x) : _) = x + 1
    90 
    +testInfix _ = 0
    91 
    +
    92 
    +data Record = Record { recVal :: Int }
    93 
    +
    94 
    +testRec :: Record -> Int
    95 
    +testRec Record{ recVal = (id -> x) } = x + 1
    96 
    +
    97 
    +testLambda :: Int -> Int
    98 
    +testLambda = \(id -> x) -> x + 1
    99 
    +
    100 
    +testLambdaCase :: Int -> Int
    101 
    +testLambdaCase = \case
    102 
    +  (id -> 5) -> 1
    103 
    +  _ -> 0
    104 
    +
    105 
    +testLambdaCases :: Int -> Int -> Int
    106 
    +testLambdaCases = \cases
    107 
    +  (id -> 5) (id -> y) -> y + 1
    108 
    +  _ _ -> 0
    109 
    +
    110 
    +testCase :: Int -> Int
    111 
    +testCase n = case n of
    112 
    +  (id -> 5) -> 1
    113 
    +  _ -> 0
    114 
    +
    115 
    +testDoExpansion :: Maybe Int -> Maybe Int
    116 
    +testDoExpansion m = do
    117 
    +  (id -> 5) <- m
    118 
    +  pure 42
    119 
    +
    120 
    +testPatBindLet :: Int -> Int
    121 
    +testPatBindLet n =
    122 
    +  let (id -> x) = n
    123 
    +      (id -> _) = undefined
    124 
    +  in x + 1
    125 
    +
    126 
    +testPatBindWhere :: Int -> Int
    127 
    +testPatBindWhere n = x + 1
    128 
    +  where (id -> x) = n
    129 
    +
    130 
    +testPatBindComp :: Int -> Int
    131 
    +testPatBindComp n =
    132 
    +  head [ x + 1
    133 
    +       | let (id -> x) = n
    134 
    +       , let (id -> _) = undefined ]
    135 
    +
    136 
    +testPatBindGuard :: Int -> Int
    137 
    +testPatBindGuard n
    138 
    +  | let (id -> x) = n, x > 0 = x + 1
    139 
    +  | otherwise = 0
    140 
    +
    141 
    +testPatBindDo :: Int -> Maybe Int
    142 
    +testPatBindDo n = do
    143 
    +  let (id -> x) = n
    144 
    +  pure (x + 1)
    145 
    +
    146 
    +testPatBindCmdLet :: Int -> Int
    147 
    +testPatBindCmdLet = proc n ->
    148 
    +  let (id -> x) = n
    149 
    +  in returnA -< x + 1
    150 
    +
    151 
    +(id -> testTopValue) = (5 :: Int)
    152 
    +
    153 
    +testPatBindTopLevel :: Int
    154 
    +testPatBindTopLevel = testTopValue + 1
    155 
    +
    156 
    +testCmdLam :: Int -> Int
    157 
    +testCmdLam = proc n ->
    158 
    +  (\(id -> x) -> returnA -< x + 1) n
    159 
    +
    160 
    +testCmdCase :: Int -> Int
    161 
    +testCmdCase = proc n ->
    162 
    +  case n of
    163 
    +    (id -> 5) -> returnA -< 1
    164 
    +    _ -> returnA -< 0
    165 
    +
    166 
    +testCmdLambdaCase :: Int -> Int
    167 
    +testCmdLambdaCase = proc n ->
    168 
    +  (\case
    169 
    +    (id -> 5) -> returnA -< 1
    170 
    +    _ -> returnA -< 0) n
    171 
    +
    172 
    +testCmdLambdaCases :: Int -> Int
    173 
    +testCmdLambdaCases = proc n ->
    174 
    +  (\cases
    175 
    +    (id -> 5) (id -> y) -> returnA -< y + 1
    176 
    +    _ _ -> returnA -< 0) n n
    177 
    +
    178 
    +main :: IO ()
    179 
    +main = do
    180 
    +  evaluate (testView 1)
    181 
    +  evaluate (testLazyForced 5)
    182 
    +  evaluate (testLazyUnforced undefined)
    183 
    +  evaluate (testAsCovered 5)
    184 
    +  evaluate (testAsUncovered undefined)
    185 
    +  evaluate (testBangCovered 5)
    186 
    +  evaluate (testBangUncovered undefined)
    187 
    +  evaluate (testSigCovered 5)
    188 
    +  evaluate (testSigUncovered undefined)
    189 
    +  evaluate (testModifiedCovered 5)
    190 
    +  evaluate (testModifiedUncovered undefined)
    191 
    +  evaluate (testList [5])
    192 
    +  evaluate (testList [])
    193 
    +  evaluate (testTuple (5, undefined))
    194 
    +  evaluate (testOr [])
    195 
    +  evaluate (testOr [5])
    196 
    +  evaluate (testOr [5, 6])
    197 
    +  evaluate (testSum (# 5 | #))
    198 
    +  evaluate (testNPat 1)
    199 
    +  evaluate (testNPat (-1))
    200 
    +  evaluate (testNPlusKPat 5)
    201 
    +  evaluate (testNPlusKPat 2)
    202 
    +  evaluate (testCoPat [5])
    203 
    +  evaluate (testCoPat [])
    204 
    +  evaluate (testQualifiedString "hello")
    205 
    +  evaluate (testQualifiedString "world")
    206 
    +  evaluate (testPrefix (Just 5))
    207 
    +  evaluate (testPrefix Nothing)
    208 
    +  evaluate (testInfix [5])
    209 
    +  evaluate (testInfix [])
    210 
    +  evaluate (testRec (Record 5))
    211 
    +  evaluate (testLambda 5)
    212 
    +  evaluate (testLambdaCase 5)
    213 
    +  evaluate (testLambdaCase 6)
    214 
    +  evaluate (testLambdaCases 5 7)
    215 
    +  evaluate (testLambdaCases 6 7)
    216 
    +  evaluate (testCase 5)
    217 
    +  evaluate (testCase 6)
    218 
    +  evaluate (maybe 0 id (testDoExpansion (Just 5)))
    219 
    +  evaluate (maybe 0 id (testDoExpansion (Just 6)))
    220 
    +  evaluate (maybe 0 id (testDoExpansion Nothing))
    221 
    +  evaluate (testPatBindLet 5)
    222 
    +  evaluate (testPatBindWhere 5)
    223 
    +  evaluate (testPatBindComp 5)
    224 
    +  evaluate (testPatBindGuard 5)
    225 
    +  evaluate (testPatBindGuard (-5))
    226 
    +  evaluate (maybe 0 id (testPatBindDo 5))
    227 
    +  evaluate (testPatBindCmdLet 5)
    228 
    +  evaluate testPatBindTopLevel
    229 
    +  evaluate (testCmdLam 5)
    230 
    +  evaluate (testCmdCase 5)
    231 
    +  evaluate (testCmdCase 6)
    232 
    +  evaluate (testCmdLambdaCase 5)
    233 
    +  evaluate (testCmdLambdaCase 6)
    234 
    +  evaluate (testCmdLambdaCases 5)
    235 
    +  evaluate (testCmdLambdaCases 6)
    236 
    +  dumpCoverage
    237 
    +
    238 
    +dumpCoverage :: IO ()
    239 
    +dumpCoverage = do
    240 
    +  Mix path _ _ _ entries <- readMix [".hpc"] (Left "Main")
    241 
    +  Tix [TixModule "Main" _ _ counts] <- examineTix
    242 
    +  src <- readFileUtf8 path
    243 
    +  putStr . compactForest . map (fmap (describe src)) . filter interesting $
    244 
    +    createMixEntryDom [ (pos, (label, count)) | ((pos, label), count) <- zip entries counts ]
    245 
    +  where
    246 
    +    interesting (Node (_, boxes) _) = any (interestingBox . fst) boxes
    247 
    +    interestingBox (TopLevelBox [name]) = "test" `isPrefixOf` name
    248 
    +    interestingBox ExpBox{} = True
    249 
    +    interestingBox _ = False
    250 
    +    describe src (pos, boxes) =
    251 
    +      intercalate ", " [ describeBox label ++ ": " ++ show count | (label, count) <- boxes ]
    252 
    +        ++ if any (hasSource . fst) boxes then " " ++ show (sourceAt src pos) else ""
    253 
    +    hasSource (ExpBox{}; BinBox{}) = True
    254 
    +    hasSource _ = False
    255 
    +    describeBox (TopLevelBox names) = intercalate "." names
    256 
    +    describeBox (ExpBox False) = "exp"
    257 
    +    describeBox (ExpBox True) = "exp-alt"
    258 
    +    describeBox (BinBox kind side) = show kind ++ " " ++ show side
    259 
    +    compactForest = unlines . filter (not . all (`elem` " |")) . lines . drawForest
    260 
    +
    261 
    +-- candidate for HPC.Utils, maybe?
    262 
    +sourceAt :: String -> HpcPos -> String
    263 
    +sourceAt src pos
    264 
    +  | l1 == l2 = take (c2 - c1 + 1) . drop (c1 - 1) $ ls !! (l1 - 1)
    265 
    +  | otherwise = intercalate "\n" $ first : (middle ++ [last])
    266 
    +  where
    267 
    +    (l1, c1, l2, c2) = fromHpcPos pos
    268 
    +    ls = lines src
    269 
    +    first = drop (c1 - 1) $ ls !! (l1 - 1)
    270 
    +    middle = take (l2 - l1 - 1) $ drop l1 ls
    271 
    +    last = take c2 $ ls !! (l2 - 1)

  • testsuite/tests/hpc/viewpats.stdout
    1 
    +testCmdLambdaCases: 1
    2 
    +`- exp: 1 "proc n ->\n  (\\cases\n    (id -> 5) (id -> y) -> returnA -< y + 1\n    _ _ -> returnA -< 0) n n"
    3 
    +   +- exp: 2 "id"
    4 
    +   +- exp: 1 "id"
    5 
    +   +- exp: 1 "returnA"
    6 
    +   +- exp: 1 "y + 1"
    7 
    +   |  +- exp: 1 "y"
    8 
    +   |  `- exp: 1 "1"
    9 
    +   +- exp: 1 "returnA"
    10 
    +   +- exp: 1 "0"
    11 
    +   +- exp: 2 "n"
    12 
    +   `- exp: 1 "n"
    13 
    +testCmdLambdaCase: 1
    14 
    +`- exp: 1 "proc n ->\n  (\\case\n    (id -> 5) -> returnA -< 1\n    _ -> returnA -< 0) n"
    15 
    +   +- exp: 2 "id"
    16 
    +   +- exp: 1 "returnA"
    17 
    +   +- exp: 1 "1"
    18 
    +   +- exp: 1 "returnA"
    19 
    +   +- exp: 1 "0"
    20 
    +   `- exp: 2 "n"
    21 
    +testCmdCase: 1
    22 
    +`- exp: 1 "proc n ->\n  case n of\n    (id -> 5) -> returnA -< 1\n    _ -> returnA -< 0"
    23 
    +   +- exp: 2 "n"
    24 
    +   +- exp: 2 "id"
    25 
    +   +- exp: 1 "returnA"
    26 
    +   +- exp: 1 "1"
    27 
    +   +- exp: 1 "returnA"
    28 
    +   `- exp: 1 "0"
    29 
    +testCmdLam: 1
    30 
    +`- exp: 1 "proc n ->\n  (\\(id -> x) -> returnA -< x + 1) n"
    31 
    +   +- exp: 1 "id"
    32 
    +   +- exp: 1 "returnA"
    33 
    +   +- exp: 1 "x + 1"
    34 
    +   |  +- exp: 1 "x"
    35 
    +   |  `- exp: 1 "1"
    36 
    +   `- exp: 1 "n"
    37 
    +exp: 1 "id"
    38 
    +exp: 1 "(5 :: Int)"
    39 
    +testPatBindTopLevel: 1
    40 
    +`- exp: 1 "testTopValue + 1"
    41 
    +   +- exp: 1 "testTopValue"
    42 
    +   `- exp: 1 "1"
    43 
    +testPatBindCmdLet: 1
    44 
    +`- exp: 1 "proc n ->\n  let (id -> x) = n\n  in returnA -< x + 1"
    45 
    +   +- exp: 1 "id"
    46 
    +   +- exp: 1 "n"
    47 
    +   +- exp: 1 "returnA"
    48 
    +   `- exp: 1 "x + 1"
    49 
    +      +- exp: 1 "x"
    50 
    +      `- exp: 1 "1"
    51 
    +testPatBindDo: 1
    52 
    +`- exp: 1 "do\n  let (id -> x) = n\n  pure (x + 1)"
    53 
    +   +- exp: 1 "pure (x + 1)"
    54 
    +   |  `- exp: 1 "(x + 1)"
    55 
    +   |     +- exp: 1 "x"
    56 
    +   |     `- exp: 1 "1"
    57 
    +   `- exp: 1 "let (id -> x) = n"
    58 
    +      +- exp: 1 "id"
    59 
    +      `- exp: 1 "n"
    60 
    +testPatBindGuard: 2
    61 
    ++- exp: 2 "id"
    62 
    ++- exp: 2 "n"
    63 
    ++- GuardBinBox True: 1, GuardBinBox False: 1, exp: 2 "x > 0"
    64 
    +|  +- exp: 2 "x"
    65 
    +|  `- exp: 2 "0"
    66 
    ++- exp-alt: 1 "x + 1"
    67 
    +|  +- exp: 1 "x"
    68 
    +|  `- exp: 1 "1"
    69 
    ++- GuardBinBox True: 1, GuardBinBox False: 0, exp: 1 "otherwise"
    70 
    +`- exp-alt: 1 "0"
    71 
    +testPatBindComp: 1
    72 
    +`- exp: 1 "head [ x + 1\n       | let (id -> x) = n\n       , let (id -> _) = undefined ]"
    73 
    +   `- exp: 1 "[ x + 1\n       | let (id -> x) = n\n       , let (id -> _) = undefined ]"
    74 
    +      +- exp: 1 "id"
    75 
    +      +- exp: 1 "n"
    76 
    +      +- exp: 0 "id"
    77 
    +      +- exp: 0 "undefined"
    78 
    +      `- exp: 1 "x + 1"
    79 
    +         +- exp: 1 "x"
    80 
    +         `- exp: 1 "1"
    81 
    +testPatBindWhere: 1
    82 
    ++- exp: 1 "id"
    83 
    ++- exp: 1 "n"
    84 
    +`- exp: 1 "x + 1"
    85 
    +   +- exp: 1 "x"
    86 
    +   `- exp: 1 "1"
    87 
    +testPatBindLet: 1
    88 
    +`- exp: 1 "let (id -> x) = n\n      (id -> _) = undefined\n  in x + 1"
    89 
    +   +- exp: 0 "id"
    90 
    +   +- exp: 0 "undefined"
    91 
    +   +- exp: 1 "id"
    92 
    +   +- exp: 1 "n"
    93 
    +   +- exp: 1 "x"
    94 
    +   `- exp: 1 "1"
    95 
    +testDoExpansion: 3
    96 
    +`- exp: 3 "do\n  (id -> 5) <- m\n  pure 42"
    97 
    +   +- exp: 1 "pure 42"
    98 
    +   |  `- exp: 1 "42"
    99 
    +   `- exp: 3 "(id -> 5) <- m"
    100 
    +      +- exp: 3 "m"
    101 
    +      `- exp: 2 "id"
    102 
    +testCase: 2
    103 
    +`- exp: 2 "case n of\n  (id -> 5) -> 1\n  _ -> 0"
    104 
    +   +- exp: 2 "n"
    105 
    +   +- exp: 2 "id"
    106 
    +   +- exp-alt: 1 "1"
    107 
    +   `- exp-alt: 1 "0"
    108 
    +testLambdaCases: 1
    109 
    +`- exp: 1 "\\cases\n  (id -> 5) (id -> y) -> y + 1\n  _ _ -> 0"
    110 
    +   +- exp: 2 "id"
    111 
    +   +- exp: 1 "id"
    112 
    +   +- exp-alt: 1 "y + 1"
    113 
    +   |  +- exp: 1 "y"
    114 
    +   |  `- exp: 1 "1"
    115 
    +   `- exp-alt: 1 "0"
    116 
    +testLambdaCase: 1
    117 
    +`- exp: 1 "\\case\n  (id -> 5) -> 1\n  _ -> 0"
    118 
    +   +- exp: 2 "id"
    119 
    +   +- exp-alt: 1 "1"
    120 
    +   `- exp-alt: 1 "0"
    121 
    +testLambda: 1
    122 
    +`- exp: 1 "\\(id -> x) -> x + 1"
    123 
    +   +- exp: 1 "id"
    124 
    +   `- exp: 1 "x + 1"
    125 
    +      +- exp: 1 "x"
    126 
    +      `- exp: 1 "1"
    127 
    +testRec: 1
    128 
    ++- exp: 1 "id"
    129 
    +`- exp: 1 "x + 1"
    130 
    +   +- exp: 1 "x"
    131 
    +   `- exp: 1 "1"
    132 
    +testInfix: 2
    133 
    ++- exp: 1 "id"
    134 
    ++- exp-alt: 1 "x + 1"
    135 
    +|  +- exp: 1 "x"
    136 
    +|  `- exp: 1 "1"
    137 
    +`- exp-alt: 1 "0"
    138 
    +testPrefix: 2
    139 
    ++- exp: 1 "id"
    140 
    ++- exp-alt: 1 "x + 1"
    141 
    +|  +- exp: 1 "x"
    142 
    +|  `- exp: 1 "1"
    143 
    +`- exp-alt: 1 "0"
    144 
    +testQualifiedString: 2
    145 
    ++- exp-alt: 1 "1"
    146 
    +`- exp-alt: 1 "0"
    147 
    +testCoPat: 2
    148 
    ++- exp: 1 "id"
    149 
    ++- exp-alt: 1 "x + 1"
    150 
    +|  +- exp: 1 "x"
    151 
    +|  `- exp: 1 "1"
    152 
    +`- exp-alt: 1 "0"
    153 
    +testNPlusKPat: 2
    154 
    ++- exp-alt: 1 "n * 2"
    155 
    +|  +- exp: 1 "n"
    156 
    +|  `- exp: 1 "2"
    157 
    +`- exp-alt: 1 "0"
    158 
    +testNPat: 2
    159 
    ++- exp-alt: 1 "10"
    160 
    ++- exp-alt: 1 "20"
    161 
    +`- exp-alt: 0 "30"
    162 
    +testSum: 1
    163 
    ++- exp: 1 "id"
    164 
    ++- exp-alt: 1 "x + 1"
    165 
    +|  +- exp: 1 "x"
    166 
    +|  `- exp: 1 "1"
    167 
    ++- exp: 0 "id"
    168 
    +`- exp-alt: 0 "y + 2"
    169 
    +   +- exp: 0 "y"
    170 
    +   `- exp: 0 "2"
    171 
    +testOr: 3
    172 
    ++- exp: 3 "id"
    173 
    ++- exp: 2 "reverse"
    174 
    ++- exp-alt: 2 "True"
    175 
    +`- exp-alt: 1 "False"
    176 
    +testTuple: 1
    177 
    ++- exp: 1 "id"
    178 
    ++- exp: 0 "id"
    179 
    +`- exp: 1 "x + 1"
    180 
    +   +- exp: 1 "x"
    181 
    +   `- exp: 1 "1"
    182 
    +testList: 2
    183 
    ++- exp: 1 "id"
    184 
    ++- exp-alt: 1 "x + 1"
    185 
    +|  +- exp: 1 "x"
    186 
    +|  `- exp: 1 "1"
    187 
    +`- exp-alt: 1 "42"
    188 
    +testModifiedUncovered: 1
    189 
    ++- exp: 0 "id"
    190 
    +`- exp: 1 "42"
    191 
    +testModifiedCovered: 1
    192 
    ++- exp: 1 "id"
    193 
    +`- exp: 1 "x + 1"
    194 
    +   +- exp: 1 "x"
    195 
    +   `- exp: 1 "1"
    196 
    +testSigUncovered: 1
    197 
    ++- exp: 0 "id"
    198 
    +`- exp: 1 "42"
    199 
    +testSigCovered: 1
    200 
    ++- exp: 1 "id"
    201 
    +`- exp: 1 "x + 1"
    202 
    +   +- exp: 1 "x"
    203 
    +   `- exp: 1 "1"
    204 
    +testBangUncovered: 1
    205 
    ++- exp: 0 "id"
    206 
    +`- exp: 1 "42"
    207 
    +testBangCovered: 1
    208 
    ++- exp: 1 "id"
    209 
    +`- exp: 1 "x + 1"
    210 
    +   +- exp: 1 "x"
    211 
    +   `- exp: 1 "1"
    212 
    +testAsUncovered: 1
    213 
    ++- exp: 0 "id"
    214 
    +`- exp: 1 "42"
    215 
    +testAsCovered: 1
    216 
    ++- exp: 1 "id"
    217 
    +`- exp: 1 "x + y"
    218 
    +   +- exp: 1 "x"
    219 
    +   `- exp: 1 "y"
    220 
    +testLazyUnforced: 1
    221 
    ++- exp: 0 "id"
    222 
    +`- exp: 1 "42"
    223 
    +testLazyForced: 1
    224 
    ++- exp: 1 "id"
    225 
    +`- exp: 1 "x + 1"
    226 
    +   +- exp: 1 "x"
    227 
    +   `- exp: 1 "1"
    228 
    +testView: 1
    229 
    ++- exp: 1 "id"
    230 
    ++- exp-alt: 1 "True"
    231 
    +`- exp-alt: 0 "False"

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/1abc18550fa898d37a5b8213cb14fb6aca9596cf at 1791945083