Hannes Siebenhandl pushed to branch wip/fendor/has-field-hie at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -21,7 +21,7 @@ import GHC.Core.Class ( className, classSCSelIds )
    21 21 
     import GHC.Core.Utils (exprType)
    22 22 
     import GHC.Core.TyCo.Rep (Type(TyConApp))
    23 23 
     import GHC.Core.TyCon (TyCon(..))
    24 
    -import GHC.Builtin.Names (hasFieldClassName, getFieldName)
    24 
    +import GHC.Builtin.Names (hasFieldClassName)
    25 25 
     import GHC.Core.ConLike           ( conLikeName )
    26 26 
     import GHC.Core.DataCon           ( dataConWrapperType )
    27 27 
     import GHC.Core.Type              ( Type, ForAllTyFlag(..) )
    ... ... @@ -687,21 +687,12 @@ hieEvIdsOfTerm :: EvTerm -> [EvId]
    687 687 
     -- Returns only EvIds satisfying relevantEvId
    688 688 
     hieEvIdsOfTerm = runFVSelectiveList isEvId . evTermFVs
    689 689
    690 
    -evFreeVarsOfTermList :: EvTerm -> [Var]
    691 
    -evFreeVarsOfTermList (EvExpr e) = exprFreeVarsList e
    692 
    -evFreeVarsOfTermList _ = []
    693 
    -
    694 
    -evDepsOfTermList :: EvTerm -> [EvId]
    695 
    -evDepsOfTermList e
    696 
    -  | isHasFieldEvTerm e = evFreeVarsOfTermList e
    697 
    -  | otherwise = evVarsOfTermList e
    698 
    -
    699 690 
     instance ToHie (EvBindContext (LocatedA TcEvBinds)) where
    700 691 
       toHie (EvBindContext sc sp (L span (EvBinds bs)))
    701 692 
         = concatMapM go $ bagToList bs
    702 693 
         where
    703 694 
           go evbind = do
    704 
    -          let evDeps = evDepsOfTermList $ eb_rhs evbind
    695 
    +          let evDeps = hieEvIdsOfTerm $ eb_rhs evbind
    705 696 
                   depNames = EvBindDeps $ map varName evDeps
    706 697 
               concatM $
    707 698 
                 [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)
    ... ... @@ -731,7 +722,8 @@ instance ToHie (LocatedA HsWrapper) where
    731 722 
             (WpEvApp a)
    732 723 
               | isHasFieldEvTerm a ->
    733 724 
                   -- concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a
    734 
    -              pprTrace "HasField" (ppr (a, osp)) $ concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a
    725 
    +              pprTrace "HasField" (ppr (a, osp)) $
    726 
    +              concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a
    735 727 
               | otherwise ->
    736 728 
                   -- pprTrace "Not HasField" (ppr (a, osp)) $ concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a
    737 729 
                   concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a

  • compiler/GHC/Rename/Expr.hs
    ... ... @@ -418,12 +418,11 @@ rnExpr (NegApp _ e _)
    418 418 
     rnExpr (HsGetField _ e f)
    419 419 
      = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
    420 420 
           ; (e, fv_e) <- rnLExpr e
    421 
    -      ; let f' = rnDotFieldOcc f
    422 
    -      ; srcSpan <- getSrcSpanM
    421 
    +      ; let f' = rnDotFieldOcc <$> f
    423 422 
           ; return ( mkExpandedExpr
    424 423 
                        (HsGetField noExtField e f')
    425 
    -                   (mkGetField srcSpan getField e (fmap (unLoc . dfoLabel) f'))
    426 
    -               , fv_e `plusFV` fv_getField ) }
    424 
    +                   (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
    425 
    +               , fv_e `plusFN` fv_getField ) }
    427 426
    428 427 
     rnExpr (HsProjection _ fs)
    429 428 
       = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
    ... ... @@ -2860,10 +2859,11 @@ rnHsIf p b1 b2
    2860 2859
    2861 2860 
     -- mkGetField arg field calculates a get_field @field arg expression.
    2862 2861 
     -- e.g. z.x = mkGetField z x = get_field @x z
    2863 
    -mkGetField :: SrcSpan -> Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
    2864 
    -mkGetField srcSpan get_field arg (L _ (FieldLabelString field)) =
    2862 
    +mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
    2863 
    +mkGetField get_field arg (L ann (FieldLabelString field)) =
    2864 
    +  pprTrace "mkGetField" (ppr ann <+> ppr field)
    2865 2865 
       -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
    2866 
    -  genHsAppWith srcSpan (genAppTypeWith srcSpan (genHsVar get_field) (genHsTyLit field)) arg
    2866 
    +  genHsAppWith (getHasLoc ann) (genHsVar get_field `genAppType` genHsTyLit field) arg
    2867 2867
    2868 2868 
     -- mkSetField a field b calculates a set_field @field expression.
    2869 2869 
     -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' to a on b").

  • compiler/GHC/Rename/Utils.hs
    ... ... @@ -17,7 +17,7 @@ module GHC.Rename.Utils (
    17 17 
             DeprecationWarnings(..), warnIfDeprecated,
    18 18 
             checkUnusedRecordWildcard,
    19 19 
             badQualBndrErr, typeAppErr, badFieldConErr,
    20 
    -        wrapGenSpan, wrapGenSpan', genHsVar, genHsVarWith, genLHsVar, genHsApp, genHsAppWith, genHsApps, genHsApps', genHsExpApps,
    20 
    +        wrapGenSpan, wrapGenSpan', wrapNoSpan, genHsVar, genHsVarWith, genLHsVar, genHsApp, genHsAppWith, genHsApps, genHsApps', genHsExpApps,
    21 21 
             genLHsApp, genAppType, genAppTypeWith,
    22 22 
             genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
    23 23 
             genVarPat, genWildPat,
    ... ... @@ -740,7 +740,7 @@ genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
    740 740 
     genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg
    741 741
    742 742 
     genHsAppWith :: SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
    743 
    -genHsAppWith srcSpan fun arg = HsApp noExtField (wrapSrcSpan srcSpan fun) arg
    743 
    +genHsAppWith srcSpan fun arg = HsApp noExtField (wrapGenSpan' srcSpan fun) arg
    744 744
    745 745 
     genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
    746 746 
     genLHsApp fun arg = wrapGenSpan (genHsApp fun arg)

  • testsuite/tests/hiefile/should_run/HasFieldQueries deleted
    No preview for this file type
  • testsuite/tests/hiefile/should_run/HasFieldQueries.hs
    1 1 
     {-# LANGUAGE OverloadedRecordDot #-}
    2 
    -{-# LANGUAGE TypeApplications #-}
    3 
    -{-# LANGUAGE DataKinds #-}
    4 2 
     module Main where
    5 3
    6 4 
     import TestUtils
    ... ... @@ -8,46 +6,43 @@ import GHC.Records
    8 6 
     import GHC.TypeLits
    9 7 
     import Data.Tree
    10 8
    11 
    -class C a where
    12 
    -  f :: a -> Char
    13 
    -
    14 
    -instance C Char where
    15 
    -  f x = x
    16 
    -
    17 9 
     data Thing = Thing {field1 :: Char, field2 :: Bool}
    18 10 
       deriving (Show, Eq)
    19 11
    20 12 
     foo :: Thing -> String
    21 13 
     foo t = show t.field1 ++ show t.field2
    22 
    -        --      ^ this is the point
    23 
    -point :: (Int,Int)
    24 
    -point = (21,17)
    25 
    -
    26 
    -bar :: Show x => x -> String
    27 
    -bar x = show [(1,x,A)]
    28 
    ---      ^ this is the point'
    29 
    -point' :: (Int,Int)
    30 
    -point' = (21,33)
    31 
    -
    32 
    -add :: Num a => a -> a -> a
    33 
    -add x y = x + y
    34 
    -
    35 
    -testing (x :: Int) =
    36 
    -  add (add x x) x
    37 
    -
    14 
    +--              ^ this is the point
    15 
    +
    38 16 
     testing2 (x :: Thing) = x.field1
    17 
    +--                      ^ this is the point
    18 
    +--                        ^ this is the point
    19 
    +
    20 
    +data NestedThing = NestedThing { nested1 :: Thing }
    39 21
    40 
    -data A = A deriving Show
    22 
    +nestedSig :: NestedThing -> Char
    23 
    +nestedSig n = n.nested1.field1
    24 
    +--              ^ this is the point
    25 
    +--                      ^ this is the point
    41 26
    42 
    -data Another = Another
    27 
    +nestedNoSig n = n.nested1.field2 :: Bool
    28 
    +--                 ^ this is the point
    29 
    +--                         ^ this is the point
    43 30
    44 
    -testing3 = (natSing :: SNat 0)
    31 
    +
    32 
    +
    33 
    +points =
    34 
    +  [ (13,17)
    35 
    +  , (16,25)
    36 
    +  , (16,27)
    37 
    +  , (23,17)
    38 
    +  , (23,25)
    39 
    +  , (27,20)
    40 
    +  , (27,28)
    41 
    +  ]
    45 42
    46 43 
     main = do
    47 44 
       (df, hf) <- readTestHie "HasFieldQueries.hie"
    48 45 
       let refmap = generateReferencesMap $ getAsts $ hie_asts hf
    49 
    -  explainEv df hf refmap point
    50 
    -
    51 
    -  explainEv df hf refmap point'
    52 46
    47 
    +  traverse (explainEv df hf refmap) points
    53 48 
       return ()

  • testsuite/tests/hiefile/should_run/HasFieldQueries.stdout
    1 1 
     ==========================
    2 
    -At point (21,17), we found:
    2 
    +At point (13,17), we found:
    3 3 
     ==========================
    4 4 
     ┌
    5 5 
     │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char
    6 
    -│     is an evidence variable bound by a let, depending on: [field1]
    6 
    +│     is an evidence variable bound by a let, depending on: [C:HasField]
    7 7 
     │           with scope: ModuleScope
    8 8 
     │
    9 9 
     │     Defined at <no location info>
    10 10 
     └
    11 11 
     |
    12 12 
     `- ┌
    13 
    -   │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char
    13 
    +   │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a
    14 14 
        │     is a usage of an external evidence variable
    15 
    -   │     Defined at HasFieldQueries.hs:17:21
    15 
    +   │     Defined in `GHC.Internal.Records'
    16 16 
        └
    17 17
    18 18 
     ==========================
    19 
    -At point (21,33), we found:
    19 
    +At point (16,25), we found:
    20 
    +==========================
    21 
    +==========================
    22 
    +At point (16,27), we found:
    23 
    +==========================
    24 
    +┌
    25 
    +│ $dHasField at HasFieldQueries.hs:16:1-32, of type: HasField "field1" Thing Char
    26 
    +│     is an evidence variable bound by a let, depending on: [C:HasField]
    27 
    +│           with scope: LocalScope HasFieldQueries.hs:16:1-32
    28 
    +│           bound at: HasFieldQueries.hs:16:1-32
    29 
    +│     Defined at <no location info>
    30 
    +└
    31 
    +|
    32 
    +`- ┌
    33 
    +   │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a
    34 
    +   │     is a usage of an external evidence variable
    35 
    +   │     Defined in `GHC.Internal.Records'
    36 
    +   └
    37 
    +
    38 
    +==========================
    39 
    +At point (23,17), we found:
    20 40 
     ==========================
    21 41 
     ┌
    22 
    -│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field2" Thing Bool
    23 
    -│     is an evidence variable bound by a let, depending on: [field2]
    42 
    +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing
    43 
    +│     is an evidence variable bound by a let, depending on: [C:HasField]
    24 44 
     │           with scope: ModuleScope
    25 45 
     │
    26 46 
     │     Defined at <no location info>
    27 47 
     └
    28 48 
     |
    29 49 
     `- ┌
    30 
    -   │ field2 at HasFieldQueries.hs:1:1, of type: Thing -> Bool
    50 
    +   │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a
    31 51 
        │     is a usage of an external evidence variable
    32 
    -   │     Defined at HasFieldQueries.hs:17:37
    52 
    +   │     Defined in `GHC.Internal.Records'
    53 
    +   └
    54 
    +
    55 
    +==========================
    56 
    +At point (23,25), we found:
    57 
    +==========================
    58 
    +┌
    59 
    +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char
    60 
    +│     is an evidence variable bound by a let, depending on: [C:HasField]
    61 
    +│           with scope: ModuleScope
    62 
    +│
    63 
    +│     Defined at <no location info>
    64 
    +└
    65 
    +|
    66 
    +`- ┌
    67 
    +   │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a
    68 
    +   │     is a usage of an external evidence variable
    69 
    +   │     Defined in `GHC.Internal.Records'
    70 
    +   └
    71 
    +
    72 
    +==========================
    73 
    +At point (27,20), we found:
    74 
    +==========================
    75 
    +┌
    76 
    +│ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "nested1" r r
    77 
    +│     is an evidence variable bound by a let, depending on: [$dHasField]
    78 
    +│           with scope: LocalScope HasFieldQueries.hs:27:1-40
    79 
    +│           bound at: HasFieldQueries.hs:27:1-40
    80 
    +│     Defined at <no location info>
    81 
    +└
    82 
    +|
    83 
    +`- ┌
    84 
    +   │ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "nested1" r r
    85 
    +   │     is an evidence variable bound by a type signature
    86 
    +   │           with scope: LocalScope HasFieldQueries.hs:27:1-40
    87 
    +   │           bound at: HasFieldQueries.hs:27:1-40
    88 
    +   │     Defined at <no location info>
    89 
    +   └
    90 
    +
    91 
    +==========================
    92 
    +At point (27,28), we found:
    93 
    +==========================
    94 
    +┌
    95 
    +│ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "field2" r Bool
    96 
    +│     is an evidence variable bound by a let, depending on: [$dHasField]
    97 
    +│           with scope: LocalScope HasFieldQueries.hs:27:1-40
    98 
    +│           bound at: HasFieldQueries.hs:27:1-40
    99 
    +│     Defined at <no location info>
    100 
    +└
    101 
    +|
    102 
    +`- ┌
    103 
    +   │ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "field2" r Bool
    104 
    +   │     is an evidence variable bound by a type signature
    105 
    +   │           with scope: LocalScope HasFieldQueries.hs:27:1-40
    106 
    +   │           bound at: HasFieldQueries.hs:27:1-40
    107 
    +   │     Defined at <no location info>
    33 108 
        └
    34 109

  • testsuite/tests/hiefile/should_run/RecordDotTypes.stdout
    1 1 
     At (22,6), got type: MyRecord
    2 
    -At (22,20), got type: Integer
    3 
    -MyRecord -> Integer
    4 
    -forall {k} (x :: k) r a. HasField x r a => r -> a
    5 
    -forall (x :: Symbol) r a. HasField x r a => r -> a
    2 
    +At (22,20), got type: MyRecord -> Integer
    6 3 
     At (22,25), got type: MyRecord
    7 
    -At (22,28), got type: String
    8 
    -MyChild -> String
    9 
    -forall {k} (x :: k) r a. HasField x r a => r -> a
    10 
    -forall (x :: Symbol) r a. HasField x r a => r -> a
    11 
    -At (22,29), got type: String
    12 
    -MyChild -> String
    13 
    -forall {k} (x :: k) r a. HasField x r a => r -> a
    14 
    -forall (x :: Symbol) r a. HasField x r a => r -> a
    4 
    +At (22,28), got type: MyChild -> String
    5 
    +At (22,29), got type: MyChild -> String

  • testsuite/tests/hiefile/should_run/T23492.hs
    ... ... @@ -24,12 +24,20 @@ g x = x.a
    24 24 
     --    ^^^
    25 25 
     --    345
    26 26
    27 
    -p1, p2, p3, p4, p5 :: (Int,Int)
    27 
    +h :: PartialFieldSelector -> Bool
    28 
    +h x = (.a) x
    29 
    +--     ^^  ^
    30 
    +--     67  8
    31 
    +
    32 
    +p1, p2, p3, p4, p5, p6, p7, p8 :: (Int,Int)
    28 33 
     p1 = (13,20)
    29 34 
     p2 = (18,7)
    30 35 
     p3 = (23,7)
    31 36 
     p4 = (23,8)
    32 37 
     p5 = (23,9)
    38 
    +p6 = (28,8)
    39 
    +p7 = (28,9)
    40 
    +p8 = (28,12)
    33 41
    34 42 
     selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
    35 43 
     selectPoint' hf loc =
    ... ... @@ -37,7 +45,7 @@ selectPoint' hf loc =
    37 45
    38 46 
     main = do
    39 47 
       (df, hf) <- readTestHie "T23492.hie"
    40 
    -  forM_ [p1,p2,p3,p4,p5] $ \point -> do
    48 
    +  forM_ [p1,p2,p3,p4,p5,p6,p7,p8] $ \point -> do
    41 49 
         putStr $ "At " ++ show point ++ ", got type: "
    42 50 
         let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point
    43 51 
         forM_ types $ \typ -> do

  • testsuite/tests/hiefile/should_run/T23492.stdout
    ... ... @@ -4,4 +4,7 @@ PartialFieldSelector
    4 4 
     At (18,7), got type: PartialFieldSelector -> Bool
    5 5 
     At (23,7), got type: PartialFieldSelector
    6 6 
     At (23,8), got type: PartialFieldSelector
    7 
    -At (23,9), got type: Bool
    7 
    +At (23,9), got type: PartialFieldSelector -> Bool
    8 
    +At (28,8), got type: PartialFieldSelector -> Bool
    9 
    +At (28,9), got type: PartialFieldSelector -> Bool
    10 
    +At (28,12), got type: PartialFieldSelector

    • —
    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/f453b12681a5846712b8b9ed85eb2c38fbbd36fc at 1786439792