[commit: ghc] wip/orf-reboot: Introduce FieldOcc for occurrences of fields in HsExpr (ad5c18c)
git at git.haskell.org
git at git.haskell.org
Tue Jul 7 15:19:30 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/orf-reboot
Link : http://ghc.haskell.org/trac/ghc/changeset/ad5c18c9e79ca39e8d24e5c409acda22e8dff3fc/ghc
>---------------------------------------------------------------
commit ad5c18c9e79ca39e8d24e5c409acda22e8dff3fc
Author: Adam Gundry <adam at well-typed.com>
Date: Wed Jul 1 15:48:30 2015 +0100
Introduce FieldOcc for occurrences of fields in HsExpr
>---------------------------------------------------------------
ad5c18c9e79ca39e8d24e5c409acda22e8dff3fc
compiler/basicTypes/FieldLabel.hs | 10 +++++++++-
compiler/hsSyn/HsExpr.hs | 7 +++----
compiler/hsSyn/HsTypes.hs | 14 ++++++++++++++
compiler/hsSyn/PlaceHolder.hs | 2 ++
compiler/rename/RnExpr.hs | 4 +++-
compiler/typecheck/TcExpr.hs | 20 ++++++++++----------
6 files changed, 41 insertions(+), 16 deletions(-)
diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs
index 34d07f4..6f901b2 100644
--- a/compiler/basicTypes/FieldLabel.hs
+++ b/compiler/basicTypes/FieldLabel.hs
@@ -39,7 +39,12 @@ dfuns/axioms differ. Each FieldLabel value is unique to its type
constructor.
-}
-{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE StandaloneDeriving #-}
module FieldLabel ( FieldLabelString
, FieldLabelEnv
@@ -54,6 +59,8 @@ import Name
import FastString
import Outputable
+import Data.Data
+
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
import Data.Traversable ( Traversable )
@@ -76,6 +83,7 @@ data FieldLbl a = FieldLabel {
flSelector :: a -- ^ Record selector function
}
deriving (Functor, Foldable, Traversable)
+deriving instance Data a => Data (FieldLbl a)
instance Outputable a => Outputable (FieldLbl a) where
ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index c13e0c5..5ad8ff2 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -135,6 +135,8 @@ data HsExpr id
-- Turned into HsVar by type checker, to support deferred
-- type errors. (The HsUnboundVar only has an OccName.)
+ | HsSingleRecFld (FieldOcc id) -- ^ Variable that corresponds to a record selector
+
| HsIPVar HsIPName -- ^ Implicit parameter
| HsOverLit (HsOverLit id) -- ^ Overloaded literals
@@ -301,9 +303,6 @@ data HsExpr id
-- For a type family, the arg types are of the *instance* tycon,
-- not the family tycon
- -- | Used to attach a selector id to non-overloaded fields
- | HsSingleRecFld RdrName id
-
-- | Expression with an explicit type signature. @e :: type@
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
@@ -773,7 +772,7 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
-ppr_expr (HsSingleRecFld f _) = ppr f
+ppr_expr (HsSingleRecFld f) = ppr f
{-
HsSyn records exactly where the user put parens, with HsPar.
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 815dd1a..536e4ee 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -33,6 +33,8 @@ module HsTypes (
ConDeclField(..), LConDeclField, pprConDeclFields,
+ FieldOcc(..),
+
HsWildCardInfo(..), mkAnonWildCardTy, mkNamedWildCardTy,
wildCardName, sameWildCard, isAnonWildCard, isNamedWildCard,
@@ -70,6 +72,7 @@ import TysWiredIn
import PrelNames( ipClassName )
import HsDoc
import BasicTypes
+import FieldLabel
import SrcLoc
import StaticFlags
import Outputable
@@ -552,6 +555,17 @@ data ConDeclField name -- Record fields have Haddoc docs on them
deriving (Typeable)
deriving instance (DataId name) => Data (ConDeclField name)
+-- | Represents an *occurrence* of an unambiguous field. We store
+-- both the 'RdrName' the user originally wrote, and after the
+-- renamer, the 'FieldLbl' including the selector function.
+data FieldOcc name = FieldOcc RdrName (PostRn name (FieldLbl name))
+
+instance Outputable (FieldOcc name) where
+ ppr (FieldOcc rdr _) = ppr rdr
+
+deriving instance (DataId name) => Data (FieldOcc name)
+
+
{-
Note [ConDeclField names]
~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index 00a2cdf..a934a17 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -12,6 +12,7 @@ import NameSet
import RdrName
import Var
import Coercion
+import FieldLabel
import Data.Data hiding ( Fixity )
import BasicTypes (Fixity)
@@ -99,6 +100,7 @@ type DataId id =
, Data (PostRn id Bool)
, Data (PostRn id Name)
, Data (PostRn id [Name])
+ , Data (PostRn id (FieldLbl id))
, Data (PostTc id Type)
, Data (PostTc id Coercion)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 1e11dea..41f436d 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -30,6 +30,7 @@ import RnPat
import DynFlags
import BasicTypes ( FixityDirection(..), Fixity(..), minPrecedence )
import PrelNames
+import FieldLabel
import Name
import NameSet
@@ -109,7 +110,8 @@ rnExpr (HsVar v)
| otherwise
-> finishHsVar name ;
Just (Right ((_, sel_name):ns)) -> ASSERT( null ns )
- return (HsSingleRecFld v sel_name, unitFV sel_name) ;
+ -- AMG TODO push up into lookupOccRn_overloaded? False is wrong!
+ return (HsSingleRecFld (FieldOcc v (FieldLabel (occNameFS $ rdrNameOcc v) False sel_name)), unitFV sel_name) ;
Just (Right []) -> error "runExpr/HsVar" } }
rnExpr (HsIPVar v)
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 8902fd1..9023d0a 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -762,8 +762,8 @@ tcExpr (RecordUpd record_expr rbnds _ _ _) res_ty
RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys }
-tcExpr (HsSingleRecFld f sel_name) res_ty
- = tcCheckRecSelId f sel_name res_ty
+tcExpr (HsSingleRecFld f) res_ty
+ = tcCheckRecSelId f res_ty
{-
************************************************************************
@@ -947,8 +947,8 @@ tcInferFun (L loc (HsVar name))
-- Don't wrap a context around a plain Id
; return (L loc fun, ty) }
-tcInferFun (L loc (HsSingleRecFld lbl name))
- = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId lbl name)
+tcInferFun (L loc (HsSingleRecFld f))
+ = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
-- Don't wrap a context around a plain Id
; return (L loc fun, ty) }
@@ -1044,10 +1044,10 @@ tcCheckId name res_ty
; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
tcWrapResult expr actual_res_ty res_ty }
-tcCheckRecSelId :: RdrName -> Name -> TcRhoType -> TcM (HsExpr TcId)
-tcCheckRecSelId lbl name res_ty
- = do { (expr, actual_res_ty) <- tcInferRecSelId lbl name
- ; addErrCtxtM (funResCtxt False (HsSingleRecFld lbl name) actual_res_ty res_ty) $
+tcCheckRecSelId :: FieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckRecSelId f res_ty
+ = do { (expr, actual_res_ty) <- tcInferRecSelId f
+ ; addErrCtxtM (funResCtxt False (HsSingleRecFld f) actual_res_ty res_ty) $
tcWrapResult expr actual_res_ty res_ty }
------------------------
@@ -1055,8 +1055,8 @@ tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
-- Infer type, and deeply instantiate
tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
-tcInferRecSelId :: RdrName -> Name -> TcM (HsExpr TcId, TcRhoType)
-tcInferRecSelId lbl n = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl n
+tcInferRecSelId :: FieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferRecSelId (FieldOcc lbl fl) = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl (flSelector fl)
------------------------
tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
More information about the ghc-commits
mailing list