Parsing for annotations

compiler/Eta/BasicTypes/JavaAnnotation.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Eta.BasicTypes.JavaAnnotation
+  ( JavaAnnotation(..)
+  , AnnExpr(..)
+  , LAnnExpr )
+where
+
+import Data.Data
+
+import Eta.BasicTypes.SrcLoc
+import Eta.Utils.FastString
+
+-- This is guaranteed to be an AnnRecord
+newtype JavaAnnotation id = JavaAnnotation { jaExpr :: LAnnExpr id }
+  deriving Data
+
+type LAnnExpr id = Located (AnnExpr id)
+
+data AnnExpr id =
+    AnnRecord (Located id) [(LString, LAnnExpr id)]
+  | AnnApply (Located id) (Maybe (LAnnExpr id))
+  | AnnCharacter Char
+  | AnnString FastString
+  | AnnInteger Integer
+  | AnnRational Rational
+  | AnnList [(LAnnExpr id)]
+  deriving Data

compiler/Eta/BasicTypes/RdrName.hs

@@ -25,6 +25,7 @@
 module Eta.BasicTypes.RdrName (
         -- * The main type
         RdrName(..),    -- Constructors exported only to BinIface
+        LRdrName,
 
         -- ** Construction
         mkRdrUnqual, mkRdrQual,
@@ -136,6 +137,8 @@ data RdrName
         -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'
   deriving (Data, Typeable)
 
+type LRdrName = Located RdrName
+
 {-
 ************************************************************************
 *                                                                      *

compiler/Eta/BasicTypes/SrcLoc.hs

@@ -65,6 +65,7 @@ module Eta.BasicTypes.SrcLoc (
         Located,
         RealLocated,
         GenLocated(..),
+        LString,
 
         -- ** Constructing Located
         noLoc,
@@ -76,7 +77,7 @@ module Eta.BasicTypes.SrcLoc (
         -- ** Combining and comparing Located values
         eqLocated, cmpLocated, combineLocs, addCLoc,
         leftmost_smallest, leftmost_largest, rightmost,
-        spans, isSubspanOf, sortLocated
+        spans, isSubspanOf, sortLocated, modifySrcSpan
     ) where
 
 import Eta.Utils.Util
@@ -605,3 +606,8 @@ isSubspanOf src parent
     | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
     | otherwise = srcSpanStart parent <= srcSpanStart src &&
                   srcSpanEnd parent   >= srcSpanEnd src
+
+modifySrcSpan :: (SrcSpan -> SrcSpan) -> Located a -> Located a
+modifySrcSpan f (L l a) = L (f l) a
+
+type LString = Located String

compiler/Eta/DeSugar/DsMeta.hs

@@ -192,7 +192,7 @@ hsSigTvBinders binds
 
 get_scoped_tvs :: LSig Name -> [Name]
 get_scoped_tvs sig
-  | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sig
+  | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _ _) <- sig
   = map hsLTyVarName $ hsQTvBndrs qtvs
   | L _ (GenericSig _ (L _ (HsForAllTy Explicit _ qtvs _ _))) <- sig
   = map hsLTyVarName $ hsQTvBndrs qtvs
@@ -833,7 +833,7 @@ rep_sigs :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_sigs = concatMapM rep_sig
 
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (L loc (TypeSig nms ty _))    = mapM (rep_ty_sig sigDName loc ty) nms
+rep_sig (L loc (TypeSig nms ty _ _))    = mapM (rep_ty_sig sigDName loc ty) nms
 -- rep_sig (L loc (PatSynSig _ _ _ nms ty))  = mapM (rep_patsyn_ty_sig loc ty) nms
 rep_sig (L _loc (PatSynSig _ _ _ _nms _ty)) = notHandled "Pattern type signatures" empty
 rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms

compiler/Eta/HsSyn/Convert.hs

@@ -170,7 +170,7 @@ cvtDec (TH.FunD nm cls)
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType typ
-        ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) }
+        ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder []) }
 
 cvtDec (TH.InfixD fx nm)
   -- Fixity signatures are allowed for variables, constructors, and types
@@ -207,7 +207,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
         ; ksig' <- cvtKind `traverse` ksig
         ; cons' <- mapM cvtConstr constrs
         ; derivs' <- cvtDerivs derivs
-        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+        ; let defn = HsDataDefn { dd_ND = DataType, dd_metaData = (Nothing, [])
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = ksig'
                                 , dd_cons = cons', dd_derivs = derivs' }
@@ -220,7 +220,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
         ; ksig' <- cvtKind `traverse` ksig
         ; con' <- cvtConstr constr
         ; derivs' <- cvtDerivs derivs
-        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+        ; let defn = HsDataDefn { dd_ND = NewType, dd_metaData = (Nothing, [])
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = ksig'
                                 , dd_cons = [con']
@@ -287,7 +287,7 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
        ; ksig' <- cvtKind `traverse` ksig
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
-       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+       ; let defn = HsDataDefn { dd_ND = DataType, dd_metaData = (Nothing, [])
                                , dd_ctxt = ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = cons', dd_derivs = derivs' }
@@ -302,7 +302,7 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
        ; ksig' <- cvtKind `traverse` ksig
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
-       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+       ; let defn = HsDataDefn { dd_ND = NewType, dd_metaData = (Nothing, [])
                                , dd_ctxt = ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = [con'], dd_derivs = derivs' }
@@ -481,21 +481,20 @@ cvtConstr (NormalC c strtys)
   = do  { c'   <- cNameL c
         ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg strtys
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
+        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') [] }
 
 cvtConstr (RecC c varstrtys)
   = do  { c'    <- cNameL c
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt'
-                                   (RecCon (noLoc args')) }
+        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon (noLoc args')) [] }
 
 cvtConstr (InfixC st1 c st2)
   = do  { c' <- cNameL c
         ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
+        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') [] }
 
 cvtConstr (ForallC tvs ctxt con)
   = do  { tvs'  <- cvtTvs tvs
@@ -509,14 +508,14 @@ cvtConstr (GadtC c strtys ty)
         ; args    <- mapM cvt_arg strtys
         ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
-        ; returnL $ mkGadtDecl c' c_ty}
+        ; returnL $ mkGadtDecl c' c_ty []}
 
 cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
         ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
         ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
-        ; returnL $ mkGadtDecl c' rec_ty }
+        ; returnL $ mkGadtDecl c' rec_ty [] }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
@@ -541,8 +540,9 @@ cvt_id_arg (i, str, ty)
   = do  { i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
         ; return $ noLoc (ConDeclField { cd_fld_names = [i']
-                                       , cd_fld_type =  ty'
-                                       , cd_fld_doc = Nothing}) }
+                                       , cd_fld_type  =  ty'
+                                       , cd_fld_doc   = Nothing
+                                       , cd_fld_anns  = [] }) }
 
 cvtDerivs :: TH.Cxt -> CvtM (Maybe (Located [LHsType RdrName]))
 cvtDerivs cxt = do

compiler/Eta/HsSyn/HsBinds.hs

@@ -32,6 +32,7 @@ import Eta.Types.Type
 import Eta.BasicTypes.Name
 import Eta.BasicTypes.NameSet
 import Eta.BasicTypes.BasicTypes
+import Eta.BasicTypes.JavaAnnotation
 import Eta.Utils.Outputable
 import Eta.BasicTypes.SrcLoc
 import Eta.BasicTypes.Var
@@ -444,7 +445,7 @@ plusHsValBinds _ _
 getTypeSigNames :: HsValBinds a -> NameSet
 -- Get the names that have a user type sig
 getTypeSigNames (ValBindsOut _ sigs)
-  = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
+  = mkNameSet [unLoc n | L _ (TypeSig names _ _ _) <- sigs, n <- names]
 getTypeSigNames _
   = panic "HsBinds.getTypeSigNames"
 
@@ -620,7 +621,7 @@ data Sig name
       --          'ApiAnnotation.AnnComma'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-    TypeSig [Located name] (LHsType name) (PostRn name [Name])
+    TypeSig [Located name] (LHsType name) (PostRn name [Name]) [JavaAnnotation name]
 
       -- | A pattern synonym type signature
       --
@@ -821,7 +822,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (TypeSig vars ty _wcs)    = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (TypeSig vars ty _wcs _anns) = pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig fix_sig)          = ppr fix_sig