Make HsAppsType contents Located
authorAlan Zimmerman <alan.zimm@gmail.com>
Mon, 21 Dec 2015 20:30:45 +0000 (22:30 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Tue, 22 Dec 2015 08:12:17 +0000 (10:12 +0200)
An HsAppInfix can carry a qconop/varop preceded by a SIMPLEQUOTE as a
Located RdrName.

In this case AnnSimpleQuote is attached to the Located HsAppType.

    | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ HsAppInfix $2)
                                           [mj AnnSimpleQuote $1] }
    | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix $2)
                                           [mj AnnSimpleQuote $1] }

This patch changes

    data HsType name
      ...
      | HsAppsTy [HsAppType name]

to

    data HsType name
      ...
      | HsAppsTy [LHsAppType name]

so that the annotation is not discarded when it reaches the ParsedSource

compiler/hsSyn/Convert.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnNames.hs
compiler/rename/RnTypes.hs
testsuite/tests/ghc-api/landmines/landmines.stdout

index 8d84378..6c35a25 100644 (file)
@@ -1227,17 +1227,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy s        (fsLit s)
 cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
 cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
   = L (combineSrcSpans loc1 loc2) $
-    HsAppsTy (t1' ++ [HsAppInfix (noLoc op)] ++ t2')
+    HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
   where
     t1' | L _ (HsAppsTy t1s) <- t1
         = t1s
         | otherwise
-        = [HsAppPrefix t1]
+        = [noLoc $ HsAppPrefix t1]
 
     t2' | L _ (HsAppsTy t2s) <- t2
         = t2s
         | otherwise
-        = [HsAppPrefix t2]
+        = [noLoc $ HsAppPrefix t2]
 
 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
 cvtKind = cvtTypeKind "kind"
index a2bdc04..00cab90 100644 (file)
@@ -27,7 +27,7 @@ module HsTypes (
         HsContext, LHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
-        HsAppType(..),
+        HsAppType(..),LHsAppType,
 
         LBangType, BangType,
         HsSrcBang(..), HsImplBang(..),
@@ -387,7 +387,7 @@ data HsType name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsAppsTy            [HsAppType name]  -- Used only before renaming,
+  | HsAppsTy            [LHsAppType name]  -- Used only before renaming,
                                           -- Note [HsAppsTy]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
@@ -542,6 +542,9 @@ data HsWildCardInfo name
     deriving (Typeable)
 deriving instance (DataId name) => Data (HsWildCardInfo name)
 
+type LHsAppType name = Located (HsAppType name)
+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote'
+
 data HsAppType name
   = HsAppInfix (Located name)       -- either a symbol or an id in backticks
   | HsAppPrefix (LHsType name)      -- anything else, including things like (+)
@@ -996,9 +999,9 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
 splitHsFunType other = ([], other)
 
 ignoreParens :: LHsType name -> LHsType name
-ignoreParens (L _ (HsParTy ty))                = ignoreParens ty
-ignoreParens (L _ (HsAppsTy [HsAppPrefix ty])) = ignoreParens ty
-ignoreParens ty                                = ty
+ignoreParens (L _ (HsParTy ty))                      = ignoreParens ty
+ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
+ignoreParens ty                                      = ty
 
 {-
 ************************************************************************
@@ -1108,9 +1111,9 @@ pprParendHsType ty = ppr_mono_ty TyConPrec ty
 
 -- Before printing a type, remove outermost HsParTy parens
 prepare :: HsType name -> HsType name
-prepare (HsParTy ty)                      = prepare (unLoc ty)
-prepare (HsAppsTy [HsAppPrefix (L _ ty)]) = prepare ty
-prepare ty                                = ty
+prepare (HsParTy ty)                            = prepare (unLoc ty)
+prepare (HsAppsTy [L _ (HsAppPrefix (L _ ty))]) = prepare ty
+prepare ty                                      = ty
 
 ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
@@ -1150,7 +1153,7 @@ ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
 
 ppr_mono_ty ctxt_prec (HsAppsTy tys)
   = maybeParen ctxt_prec TyConPrec $
-    hsep (map (ppr_app_ty TopPrec) tys)
+    hsep (map (ppr_app_ty TopPrec . unLoc) tys)
 
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec TyConPrec $
index 3cfcb06..c37785b 100644 (file)
@@ -968,7 +968,9 @@ hsConDeclsBinders cons = go id cons
              L loc (ConDeclGADT { con_names = names
                                 , con_type = HsIB { hsib_body = res_ty}}) ->
                case tau of
-                 L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _res_ty)
+                 L _ (HsFunTy
+                      (L _ (HsAppsTy
+                            [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
                          -> record_gadt flds
                  L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
                          -> record_gadt flds
@@ -1109,7 +1111,7 @@ lPatImplicits = hs_lpat
 
 -- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
 -- without consulting fixities.
-getAppsTyHead_maybe :: [HsAppType name] -> Maybe (LHsType name, [LHsType name])
+getAppsTyHead_maybe :: [LHsAppType name] -> Maybe (LHsType name, [LHsType name])
 getAppsTyHead_maybe tys = case splitHsAppsTy tys of
   ([app1:apps], []) ->  -- no symbols, some normal types
     Just (mkHsAppTys app1 apps, [])
@@ -1124,13 +1126,13 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of
 -- element of @non_syms@ followed by the first element of @syms@ followed by
 -- the next element of @non_syms@, etc. It is guaranteed that the non_syms list
 -- has one more element than the syms list.
-splitHsAppsTy :: [HsAppType name] -> ([[LHsType name]], [Located name])
+splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name])
 splitHsAppsTy = go [] [] []
   where
     go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
-    go acc acc_non acc_sym (HsAppPrefix ty : rest)
+    go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
       = go (ty : acc) acc_non acc_sym rest
-    go acc acc_non acc_sym (HsAppInfix op : rest)
+    go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
       = go [] (reverse acc : acc_non) (op : acc_sym) rest
 
 -- retrieve the name of the "head" of a nested type application
index 410f4c7..d6255a3 100644 (file)
@@ -1662,12 +1662,12 @@ btype_no_ops :: { LHsType RdrName }
         : btype_no_ops atype            { sLL $1 $> $ HsAppTy $1 $2 }
         | atype                         { $1 }
 
-tyapps :: { Located [HsAppType RdrName] }   -- NB: This list is reversed
-        : tyapp                         { sL1 $1 [unLoc $1] }
-        | tyapps tyapp                  { sLL $1 $> $ (unLoc $2) : (unLoc $1) }
+tyapps :: { Located [LHsAppType RdrName] }   -- NB: This list is reversed
+        : tyapp                         { sL1 $1 [$1] }
+        | tyapps tyapp                  { sLL $1 $> $ $2 : (unLoc $1) }
 
 -- See Note [HsAppsTy] in HsTypes
-tyapp :: { Located (HsAppType RdrName) }
+tyapp :: { LHsAppType RdrName }
         : atype                         { sL1 $1 $ HsAppPrefix $1 }
         | qtyconop                      { sL1 $1 $ HsAppInfix $1 }
         | tyvarop                       { sL1 $1 $ HsAppInfix $1 }
index 5da1bab..c3c356a 100644 (file)
@@ -652,10 +652,11 @@ checkTyVars pp_what equals_or_where tc tparms
   where
 
     chk (L _ (HsParTy ty)) = chk ty
-    chk (L _ (HsAppsTy [HsAppPrefix ty])) = chk ty
+    chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig (L _ (HsAppsTy [HsAppPrefix (L lv (HsTyVar (L _ tv)))])) k))
+    chk (L l (HsKindSig
+              (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar (L _ tv))))])) k))
         | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
     chk (L l (HsTyVar (L ltv tv)))
         | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
@@ -715,7 +716,7 @@ checkTyClHdr is_cls ty
     go _ (HsAppsTy ts)   acc ann
       | Just (head, args) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann
 
-    go _ (HsAppsTy [HsAppInfix (L loc star)]) [] ann
+    go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann
       | occNameFS (rdrNameOcc star) == fsLit "*"
       = return (L loc (nameRdrName starKindTyConName), [], ann)
       | occNameFS (rdrNameOcc star) == fsLit "★"
@@ -740,7 +741,7 @@ checkContext (L l orig_t)
     = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
 
     -- don't let HsAppsTy get in the way
-  check anns (L _ (HsAppsTy [HsAppPrefix ty]))
+  check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
     = check anns ty
 
   check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
@@ -1070,14 +1071,17 @@ splitTilde t = go t
 
 -- | Transform tyapps with strict_marks into uses of twiddle
 -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
-splitTildeApps :: [HsAppType RdrName] -> [HsAppType RdrName]
+splitTildeApps :: [LHsAppType RdrName] -> [LHsAppType RdrName]
 splitTildeApps []         = []
 splitTildeApps (t : rest) = t : concatMap go rest
-  where go (HsAppPrefix
+  where go (L l (HsAppPrefix
             (L loc (HsBangTy
                     (HsSrcBang Nothing NoSrcUnpack SrcLazy)
-                    ty)))
-          = [HsAppInfix (L tilde_loc eqTyCon_RDR), HsAppPrefix ty]
+                    ty))))
+          = [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
+             L l (HsAppPrefix ty)]
+             -- NOTE: no annotation is attached to an HsAppPrefix, so the
+             --       surrounding SrcSpan is not critical
           where
             tilde_loc = srcSpanFirstCharacter loc
 
index 4c96861..66af301 100644 (file)
@@ -628,7 +628,9 @@ getLocalNonValBinders fixity_env
             where
               (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
               cdflds = case tau of
-                 L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _) -> flds
+                 L _ (HsFunTy
+                      (L _ (HsAppsTy
+                        [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
                  L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
                  _                                    -> []
         find_con_flds _ = []
index dc6b7a6..2fc581e 100644 (file)
@@ -996,7 +996,7 @@ collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)]
 collectWildCards lty = go lty
   where
     go (L loc ty) = case ty of
-      HsAppsTy tys            -> gos (mapMaybe prefix_types_only tys)
+      HsAppsTy tys            -> gos (mapMaybe (prefix_types_only . unLoc) tys)
       HsAppTy ty1 ty2         -> go ty1 `mappend` go ty2
       HsFunTy ty1 ty2         -> go ty1 `mappend` go ty2
       HsListTy ty             -> go ty
@@ -1619,12 +1619,13 @@ extract_lty t_or_k (L _ ty) acc
       HsWildCardTy {}           -> return acc
 
 extract_apps :: TypeOrKind
-             -> [HsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
+             -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
 
-extract_app :: TypeOrKind -> HsAppType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_app t_or_k (HsAppInfix tv)  acc = extract_tv t_or_k tv acc
-extract_app t_or_k (HsAppPrefix ty) acc = extract_lty t_or_k ty acc
+extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars
+            -> RnM FreeKiTyVars
+extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc
+extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
 
 extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars
                     -> FreeKiTyVars -> RnM FreeKiTyVars