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

Commits:

9 changed files:

Changes:

  • changelog.d/record-dot-evidence
    1 
    +section: compiler
    2 
    +synopsis: Record selector functions as evidence for `HasField` constraints during .hie file generation.
    3 
    +description: {
    4 
    +    We record the record selector `foo` of an expression such as `f.foo` as evidence for
    5 
    +    solving the constraint `HasField "foo" record ty`.
    6 
    +
    7 
    +    This allows us to point to the definition source location of the record selector `foo`, allowing
    8 
    +    users to jump to definition using the evidence variables.
    9 
    +}
    10 
    +
    11 
    +issues: #25418
    12 
    +mrs: !16694

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -23,7 +23,6 @@ import GHC.Core.DataCon ( dataConWrapperType )
    23 23 
     import GHC.Core.Type              ( Type, ForAllTyFlag(..) )
    24 24 
     import GHC.Core.TyCon             ( TyCon, tyConClass_maybe )
    25 25 
     import GHC.Core.InstEnv
    26 
    -import GHC.Core.Predicate         ( isEvId )
    27 26
    28 27 
     import GHC.Hs
    29 28 
     import GHC.Hs.Syn.Type
    ... ... @@ -33,7 +32,7 @@ import GHC.Types.Basic
    33 32 
     import GHC.Types.UnresolvedImport ( isGeneratedImport )
    34 33 
     import GHC.Types.FieldLabel
    35 34 
     import GHC.Types.Avail            ( Avails )
    36 
    -import GHC.Types.Id               ( isDataConId_maybe )
    35 
    +import GHC.Types.Id               ( isDataConId_maybe, isId, idDetails )
    37 36 
     import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName )
    38 37 
     import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
    39 38 
     import GHC.Types.Name.Reader      ( RecFieldInfo(..), WithUserRdr(..) )
    ... ... @@ -81,6 +80,7 @@ import Control.Applicative ( (<|>) )
    81 80 
     import GHC.Types.TypeEnv          ( TypeEnv )
    82 81 
     import Control.Arrow              ( second )
    83 82 
     import Data.Traversable           ( mapAccumR )
    83 
    +import GHC.Types.Id.Info (IdDetails(..), recSelParentName)
    84 84
    85 85 
     {- Note [Updating HieAst for changes in the GHC AST]
    86 86 
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -682,7 +682,7 @@ instance ToHie (Context (Located (WithUserRdr Name))) where
    682 682
    683 683 
     hieEvIdsOfTerm :: EvTerm -> [EvId]
    684 684 
     -- Returns only EvIds satisfying relevantEvId
    685 
    -hieEvIdsOfTerm = runFVSelectiveList isEvId . evTermFVs
    685 
    +hieEvIdsOfTerm = runFVSelectiveList isId . evTermFVs
    686 686
    687 687 
     instance ToHie (EvBindContext (LocatedA TcEvBinds)) where
    688 688 
       toHie (EvBindContext sc sp (L span (EvBinds bs)))
    ... ... @@ -690,7 +690,7 @@ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where
    690 690 
         where
    691 691 
           go evbind = do
    692 692 
               let evDeps = hieEvIdsOfTerm $ eb_rhs evbind
    693 
    -              depNames = EvBindDeps $ map varName evDeps
    693 
    +              depNames = EvBindDeps $ map classifyEvBindDep evDeps
    694 694 
               concatM $
    695 695 
                 [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)
    696 696 
                                             (L span $ eb_lhs evbind))
    ... ... @@ -698,6 +698,12 @@ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where
    698 698 
                 ]
    699 699 
       toHie _ = pure []
    700 700
    701 
    +classifyEvBindDep :: EvId -> EvBindDep
    702 
    +classifyEvBindDep evId =
    703 
    +  case idDetails evId of
    704 
    +    RecSelId{sel_tycon} -> RecordField (varName evId) (recSelParentName sel_tycon)
    705 
    +    _ -> EvidenceVar (varName evId)
    706 
    +
    701 707 
     instance ToHie (LocatedA HsWrapper) where
    702 708 
       toHie (L osp wrap)
    703 709 
         = case wrap of

  • compiler/GHC/Iface/Ext/Types.hs
    ... ... @@ -598,17 +598,61 @@ instance Outputable EvVarSource where
    598 598 
       ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls
    599 599 
       ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
    600 600
    601 
    +data EvBindDep
    602 
    +  = EvidenceVar Name
    603 
    +  | RecordField Name Name
    604 
    +  | TypeableEvidence Name
    605 
    +  deriving (Eq, Ord)
    606 
    +
    607 
    +instance Outputable EvBindDep where
    608 
    +  ppr = \ case
    609 
    +    EvidenceVar n -> ppr n
    610 
    +    RecordField sel parent -> ppr sel <+> text "of Record" <+> ppr parent
    611 
    +    TypeableEvidence n -> ppr n <+> text "bound by Typeable"
    612 
    +
    613 
    +evBindDepName :: EvBindDep -> Name
    614 
    +evBindDepName = \ case
    615 
    +  EvidenceVar n -> n
    616 
    +  RecordField selector _record -> selector
    617 
    +  TypeableEvidence n -> n
    618 
    +
    619 
    +evBindDepHieName :: EvBindDep -> HieName
    620 
    +evBindDepHieName = toHieName . evBindDepName
    621 
    +
    622 
    +instance Binary EvBindDep where
    623 
    +  put_ bh = \ case
    624 
    +    EvidenceVar n -> do
    625 
    +      putByte bh 0
    626 
    +      put_ bh n
    627 
    +    RecordField n sel -> do
    628 
    +      putByte bh 1
    629 
    +      put_ bh n
    630 
    +      put_ bh sel
    631 
    +    TypeableEvidence n -> do
    632 
    +      putByte bh 2
    633 
    +      put_ bh n
    634 
    +
    635 
    +  get bh =
    636 
    +    getByte bh >>= \ case
    637 
    +      0 -> EvidenceVar <$> get bh
    638 
    +      1 -> RecordField <$> get bh <*> get bh
    639 
    +      2 -> TypeableEvidence <$> get bh
    640 
    +      t -> fail $ "EvBindDep: Unknown tag: " ++ show t
    641 
    +
    601 642 
     -- | Eq/Ord instances compare on the converted HieName,
    602 643 
     -- as non-exported names may have different uniques after
    603 644 
     -- a roundtrip
    604 
    -newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
    645 
    +newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [EvBindDep] }
    605 646 
       deriving Outputable
    606 647
    648 
    +evBindDepsNames :: EvBindDeps -> [Name]
    649 
    +evBindDepsNames = map evBindDepName . getEvBindDeps
    650 
    +
    607 651 
     instance Eq EvBindDeps where
    608 
    -  (==) = coerce ((==) `on` map toHieName)
    652 
    +  (==) = coerce ((==) `on` map evBindDepHieName)
    609 653
    610 654 
     instance Ord EvBindDeps where
    611 
    -  compare = coerce (compare `on` map toHieName)
    655 
    +  compare = coerce (compare `on` map evBindDepHieName)
    612 656
    613 657 
     instance Binary EvBindDeps where
    614 658 
       put_ bh (EvBindDeps xs) = put_ bh xs

  • compiler/GHC/Iface/Ext/Utils.hs
    ... ... @@ -145,7 +145,7 @@ getEvidenceTree refmap var = go emptyNameSet var
    145 145 
                      det <- S.toList $ identInfo dets
    146 146 
                      case det of
    147 147 
                        EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
    148 
    -                     pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
    148 
    +                     pure $ Just ((src,scp,spn),mapMaybe (go (extendNameSet seen var) . evBindDepName) xs)
    149 149 
                        EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])
    150 150 
                        _ -> pure Nothing
    151 151 
                   pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
    ... ... @@ -390,7 +390,7 @@ definedInAsts asts n = case nameSrcSpan n of
    390 390
    391 391 
     getEvidenceBindDeps :: ContextInfo -> [Name]
    392 392 
     getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =
    393 
    -  getEvBindDeps xs
    393 
    +  evBindDepsNames xs
    394 394 
     getEvidenceBindDeps _ = []
    395 395
    396 396 
     isEvidenceBind :: ContextInfo -> Bool

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

  • testsuite/tests/hiefile/should_run/HieTypeable.hs
    1 
    +module Main where
    2 
    +
    3 
    +import Data.Dynamic
    4 
    +import Data.Typeable
    5 
    +import TestUtils
    6 
    +
    7 
    +data Thing = Thing {field1 :: Char, field2 :: Bool}
    8 
    +  deriving (Show, Eq)
    9 
    +
    10 
    +castFromDynamic :: Dynamic -> Maybe Thing
    11 
    +castFromDynamic d = fromDynamic d
    12 
    +                 -- ^ this is the point
    13 
    +
    14 
    +rep :: Thing -> TypeRep
    15 
    +rep d = typeOf d
    16 
    +      -- ^ this is the point
    17 
    +
    18 
    +points =
    19 
    +  [ (11,21)
    20 
    +  , (15,10)
    21 
    +  ]
    22 
    +
    23 
    +main = do
    24 
    +  (df, hf) <- readTestHie "HieTypeable.hie"
    25 
    +  let refmap = generateReferencesMap $ getAsts $ hie_asts hf
    26 
    +
    27 
    +  traverse (explainEv df hf refmap) points
    28 
    +  return ()

  • testsuite/tests/hiefile/should_run/HieTypeable.stdout
    1 
    +==========================
    2 
    +At point (11,21), we found:
    3 
    +==========================
    4 
    +┌
    5 
    +│ $dTypeable at HieTypeable.hs:1:1, of type: Typeable Thing
    6 
    +│     is an evidence variable bound by a let, depending on: [$dTypeable]
    7 
    +│           with scope: ModuleScope
    8 
    +│
    9 
    +│     Defined at <no location info>
    10 
    +└
    11 
    +|
    12 
    +`- ┌
    13 
    +   │ $dTypeable at HieTypeable.hs:1:1, of type: Typeable Thing
    14 
    +   │     is an evidence variable bound by a let, depending on: []
    15 
    +   │           with scope: ModuleScope
    16 
    +   │
    17 
    +   │     Defined at <no location info>
    18 
    +   └
    19 
    +
    20 
    +==========================
    21 
    +At point (15,10), we found:
    22 
    +==========================
    23 
    +┌
    24 
    +│ $dTypeable at HieTypeable.hs:1:1, of type: Typeable Thing
    25 
    +│     is an evidence variable bound by a let, depending on: []
    26 
    +│           with scope: ModuleScope
    27 
    +│
    28 
    +│     Defined at <no location info>
    29 
    +└
    30 
    +

  • testsuite/tests/hiefile/should_run/RecordDotTypes.stdout
    1 1 
     At (22,6), got type: MyRecord
    2 2 
     At (22,20), got type: MyRecord -> Integer
    3 3 
     At (22,25), got type: MyRecord
    4 
    -At (22,28), got type: MyChild -> String
    5 
    -At (22,29), got type: MyChild -> String
    6 
    -At (22,6) - (22,8), got type: String
    4 
    +At (22,28), got type: MyChild -> [Char]
    5 
    +At (22,29), got type: MyChild -> [Char]
    6 
    +At (22,6) - (22,8), got type: [Char]
    7 7 
     At (22,17) - (22,20), got type: Integer
    8 8 
     At (22,25) - (22,27), got type: MyChild
    9 
    -At (22,25) - (22,29), got type: String
    9 
    +At (22,25) - (22,29), got type: [Char]

  • testsuite/tests/hiefile/should_run/all.T
    ... ... @@ -11,3 +11,4 @@ test('T24544', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti
    11 11 
     test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
    12 12 
     test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
    13 13 
     test('HasFieldQueries', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
    14 
    +test('HieTypeable', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])

    • —
    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/-/compare/1793ebd827282dcd8e6900e798cca045e4db42e5...bb8f0d262689a9ae75cd31cfe9a03a53267a98ee at 1789570688