Commit 7927658e authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp

AST changes to prepare for API annotations, for #9628

Summary:
AST changes to prepare for API annotations

Add locations to parts of the AST so that API annotations can
then be added.

The outline of the whole process is captured here
https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations

This change updates the haddock submodule.

Test Plan: sh ./validate

Reviewers: austin, simonpj, Mikolaj

Reviewed By: simonpj, Mikolaj

Subscribers: thomie, goldfire, carter

Differential Revision: https://phabricator.haskell.org/D426

GHC Trac Issues: #9628
parent cfa574ce
......@@ -89,6 +89,7 @@ module BasicTypes(
import FastString
import Outputable
import SrcLoc ( Located,unLoc )
import Data.Data hiding (Fixity)
import Data.Function (on)
......@@ -263,14 +264,14 @@ initialVersion = 1
\begin{code}
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt = WarningTxt [FastString]
| DeprecatedTxt [FastString]
data WarningTxt = WarningTxt [Located FastString]
| DeprecatedTxt [Located FastString]
deriving (Eq, Data, Typeable)
instance Outputable WarningTxt where
ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws))
ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
doubleQuotes (vcat (map ftext ds))
doubleQuotes (vcat (map (ftext . unLoc) ds))
\end{code}
%************************************************************************
......
......@@ -166,8 +166,9 @@ untidy_con :: HsConPatDetails Name -> HsConPatDetails Name
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
untidy_con (RecCon (HsRecFields flds dd))
= RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }
| fld <- flds ] dd)
= RecCon (HsRecFields [ L l (fld { hsRecFieldArg
= untidy_pars (hsRecFieldArg fld) })
| L l fld <- flds ] dd)
pars :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p
......@@ -765,7 +766,8 @@ tidy_con con (RecCon (HsRecFields fs _))
field_pats = case con of
RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"
all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
all_pats = foldr (\(L _ (HsRecField id p _)) acc
-> insertNm (getName (unLoc id)) p acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
......
......@@ -593,9 +593,10 @@ addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
; return (L l (Present e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
......@@ -891,9 +892,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
= do { fields' <- mapM process fields
; return (HsRecFields fields' dd) }
where
process (HsRecField ids expr doc)
process (L l (HsRecField ids expr doc))
= do { expr' <- addTickLHsExpr expr
; return (HsRecField ids expr' doc) }
; return (L l (HsRecField ids expr' doc)) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
......
......@@ -349,7 +349,7 @@ Reason
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
......@@ -373,7 +373,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
rule = mkRule False {- Not auto -} is_local
name act fn_name final_bndrs args final_rhs
(unLoc name) act fn_name final_bndrs args
final_rhs
inline_shadows_rule -- Function can be inlined before rule fires
| wopt Opt_WarnInlineRuleShadowing dflags
......@@ -390,7 +391,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
| otherwise = False
; when inline_shadows_rule $
warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)
warnDs (vcat [ hang (ptext (sLit "Rule")
<+> doubleQuotes (ftext $ unLoc name)
<+> ptext (sLit "may never fire"))
2 (ptext (sLit "because") <+> quotes (ppr fn_id)
<+> ptext (sLit "might inline first"))
......
......@@ -278,12 +278,12 @@ dsExpr (SectionR op expr) = do
Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (Missing ty)
= do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need
-- another lambda in the desugaring.
= do { lam_var <- newSysLocalDs ty
; return (lam_var : lam_vars, Var lam_var : args) }
go (lam_vars, args) (Present expr)
go (lam_vars, args) (L _ (Present expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExpr expr
......@@ -495,15 +495,15 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) }
where
ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
-- Clone the Id in the HsRecField, because its Name is that
-- of the record selector, and we must not make that a lcoal binder
-- else we shadow other uses of the record selector
-- Hence 'lcl_id'. Cf Trac #2735
ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
; let fld_id = unLoc (hsRecFieldId rec_field)
; lcl_id <- newSysLocalDs (idType fld_id)
; return (idName fld_id, lcl_id, rhs) }
ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
; let fld_id = unLoc (hsRecFieldId rec_field)
; lcl_id <- newSysLocalDs (idType fld_id)
; return (idName fld_id, lcl_id, rhs) }
add_field_binds [] expr = expr
add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
......@@ -613,9 +613,9 @@ dsExpr (HsType {}) = panic "dsExpr:HsType"
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
findField :: [HsRecField Id arg] -> Name -> [arg]
findField :: [LHsRecField Id arg] -> Name -> [arg]
findField rbinds lbl
= [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
= [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
, lbl == idName (unLoc id) ]
\end{code}
......
......@@ -107,7 +107,8 @@ dsForeigns' fos = do
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
do_decl (ForeignExport (L _ id) _ co
(CExport (L _ (CExportStatic ext_nm cconv)) _)) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
\end{code}
......@@ -142,8 +143,8 @@ dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id co (CImport cconv safety mHeader spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety mHeader
dsFImport id co (CImport cconv safety mHeader spec _) = do
(ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
return (ids, h, c)
dsCImport :: Id
......
......@@ -63,6 +63,7 @@ import DynFlags
import FastString
import ForeignCall
import Util
import MonadUtils
import Data.Maybe
import Control.Monad
......@@ -154,7 +155,8 @@ repTopDs group@(HsGroup { hs_valds = valds
-- more needed
; return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
val_ds ++ catMaybes tycl_ds ++ role_ds
++ (concat fix_ds)
++ inst_ds ++ rule_ds ++ for_ds
++ ann_ds ++ deriv_ds) }) ;
......@@ -293,8 +295,15 @@ repDataDefn tc bndrs opt_tys tv_names
; derivs1 <- repDerivs mb_derivs
; case new_or_data of
NewType -> do { con1 <- repC tv_names (head cons)
; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
; case con1 of
[c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
_cs -> failWithDs (ptext
(sLit "Multiple constructors for newtype:")
<+> pprQuotedList
(con_names $ unLoc $ head cons))
}
DataType -> do { consL <- concatMapM (repC tv_names) cons
; cons1 <- coreList conQTyConName consL
; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
......@@ -464,7 +473,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
; repDataDefn tc bndrs (Just tys1) tv_names defn } }
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
= do MkC name' <- lookupLOcc name
MkC typ' <- repLTy typ
MkC cc' <- repCCallConv cc
......@@ -499,16 +508,18 @@ repSafety PlayRisky = rep2 unsafeName []
repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
repFixD (L loc (FixitySig name (Fixity prec dir)))
= do { MkC name' <- lookupLOcc name
; MkC prec' <- coreIntLit prec
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
InfixR -> infixRDName
InfixN -> infixNDName
; dec <- rep2 rep_fn [prec', name']
; return (loc, dec) }
; let do_one name
= do { MkC name' <- lookupLOcc name
; dec <- rep2 rep_fn [prec', name']
; return (loc,dec) }
; mapM do_one names }
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
......@@ -516,7 +527,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
; ss <- mkGenSyms bndr_names
; rule1 <- addBinds ss $
do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
; n' <- coreStringLit $ unpackFS n
; n' <- coreStringLit $ unpackFS $ unLoc n
; act' <- repPhases act
; lhs' <- repLE lhs
; rhs' <- repLE rhs
......@@ -524,16 +535,16 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
; rule2 <- wrapGenSyms ss rule1
; return (loc, rule2) }
ruleBndrNames :: RuleBndr Name -> [Name]
ruleBndrNames (RuleBndr n) = [unLoc n]
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
= unLoc n : kvs ++ tvs
repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy ty
; rep2 typedRuleVarName [n', ty'] }
......@@ -562,14 +573,14 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
-- Constructors
-------------------------------------------------------
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
, con_details = details, con_res = ResTyH98 }))
| null (hsQTvBndrs con_tvs)
= do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
; repConstr con1 details }
= do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences]
; mapM (\c -> repConstr c details) con1 }
repC tvs (L _ (ConDecl { con_name = con
repC tvs (L _ (ConDecl { con_names = cons
, con_qvars = con_tvs, con_cxt = L _ ctxt
, con_details = details
, con_res = res_ty }))
......@@ -578,12 +589,14 @@ repC tvs (L _ (ConDecl { con_name = con
, hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
; binds <- mapM dupBinder con_tv_subst
; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
; c' <- repConstr con1 details
do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
; c' <- mapM (\c -> repConstr c details) cons1
; ctxt' <- repContext (eq_ctxt ++ ctxt)
; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
; return [b]
}
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst [] _ = False
......@@ -646,9 +659,9 @@ repBangTy ty= do
-- Deriving clause
-------------------------------------------------------
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
repDerivs Nothing = coreList nameTyConName []
repDerivs (Just ctxt)
repDerivs (Just (L _ ctxt))
= repList nameTyConName rep_deriv ctxt
where
rep_deriv :: LHsType Name -> DsM (Core TH.Name)
......@@ -680,7 +693,8 @@ rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty)
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
rep_sig (L loc (SpecSig nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys
rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
......@@ -1046,8 +1060,9 @@ repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
| isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
| otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
| isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
| otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
; repUnboxedTup xs }
repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
......@@ -1133,9 +1148,9 @@ repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
= repList fieldExpQTyConName rep_fld flds
where
rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
-----------------------------------------------------------------------------
......@@ -1360,9 +1375,9 @@ repP (ConPatIn dc details)
repPinfix p1' con_str p2' }
}
where
rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
......@@ -1831,13 +1846,16 @@ repConstr :: Core TH.Name -> HsConDeclDetails Name
repConstr con (PrefixCon ps)
= do arg_tys <- repList strictTypeQTyConName repBangTy ps
rep2 normalCName [unC con, unC arg_tys]
repConstr con (RecCon ips)
= do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips
= do { args <- concatMapM rep_ip ips
; arg_vtys <- coreList varStrictTypeQTyConName args
; rep2 recCName [unC con, unC arg_vtys] }
where
rep_ip ip = do { MkC v <- lookupLOcc (cd_fld_name ip)
; MkC ty <- repBangTy (cd_fld_type ip)
; rep2 varStrictTypeName [v,ty] }
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
rep_one_ip t n = do { MkC v <- lookupLOcc n
; MkC ty <- repBangTy t
; rep2 varStrictTypeName [v,ty] }
repConstr con (InfixCon st1 st2)
= do arg1 <- repBangTy st1
......
......@@ -973,8 +973,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp _ _ = False
---------
tup_arg (Present e1) (Present e2) = lexp e1 e2
tup_arg (Missing t1) (Missing t2) = eqType t1 t2
tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
tup_arg _ _ = False
---------
......
......@@ -187,8 +187,8 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
= arg_vars
where
fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
lookup_fld rpat = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
matchOneConLike _ _ [] = panic "matchOneCon []"
......@@ -203,7 +203,8 @@ compatible_pats _ _ = True -- Prefix or infix co
same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
same_fields flds1 flds2
= all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
= all2 (\(L _ f1) (L _ f2)
-> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
(rec_flds flds1) (rec_flds flds2)
......@@ -224,7 +225,7 @@ conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
| null rpats = map WildPat arg_tys
-- Important special case for C {}, which can be used for a
-- datacon that isn't declared to have fields at all
| otherwise = map (unLoc . hsRecFieldArg) rpats
| otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats
\end{code}
Note [Record patterns]
......
......@@ -176,7 +176,7 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm
; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
......@@ -208,7 +208,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = Nothing
, dd_cons = [con'], dd_derivs = derivs' }
, dd_cons = [con']
, dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdFVs = placeHolderNames }) }
......@@ -416,7 +417,8 @@ cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
; returnL $ mkSimpleConDecl c' noExistentials cxt'
(RecCon args') }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
......@@ -437,16 +439,18 @@ cvt_arg (NotStrict, ty) = cvtType ty
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing True) ty' }
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
cvt_id_arg (i, str, ty)
= do { i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
; return $ noLoc (ConDeclField { cd_fld_names = [i']
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName]))
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
; return (Just cs') }
; return (Just (noLoc cs')) }
where
cvt_one c = do { c' <- tconName c
; returnL $ HsTyVar c' }
......@@ -463,8 +467,9 @@ noExistentials = []
cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
| Just impspec <- parseCImport (cvt_conv callconv) safety'
(mkFastString (TH.nameBase nm)) from
| Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
(mkFastString (TH.nameBase nm))
from (noLoc (mkFastString from))
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
......@@ -480,7 +485,9 @@ cvtForD (ImportF callconv safety from nm ty)
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
; let e = CExport (noLoc (CExportStatic (mkFastString as)
(cvt_conv callconv)))
(noLoc (mkFastString as))
; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
cvt_conv :: TH.Callconv -> CCallConv
......@@ -514,7 +521,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ SpecSig nm' ty' ip }
; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
......@@ -526,7 +533,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
; bndrs' <- mapM cvtRuleBndr bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
; returnJustL $ Hs.RuleD $ HsRule nm' act bndrs'
; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs'
lhs' placeHolderNames
rhs' placeHolderNames
}
......@@ -567,14 +574,14 @@ cvtPhases AllPhases dflt = dflt
cvtPhases (FromPhase i) _ = ActiveAfter i
cvtPhases (BeforePhase i) _ = ActiveBefore i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
cvtRuleBndr (RuleVar n)
= do { n' <- vNameL n
; return $ Hs.RuleBndr n' }
; return $ noLoc $ Hs.RuleBndr n' }
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameL n
; ty' <- cvtType ty
; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
---------------------------------------------------
-- Declarations
......@@ -622,8 +629,12 @@ cvtl e = wrapL (cvt e)
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
cvt (TupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple (map (noLoc . Present) es')
Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple
(map (noLoc . Present) es') Unboxed }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
......@@ -694,10 +705,11 @@ and the above expression would be reassociated to
which we don't want.
-}
cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName))
cvtFld (v,e)
= do { v' <- vNameL v; e' <- cvtl e
; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e'
, hsRecPun = False}) }
cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
......@@ -907,10 +919,11 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat e' p' placeHolderType }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
cvtPatFld (s,p)
= do { s' <- vNameL s; p' <- cvtPat p
; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p'
, hsRecPun = False}) }
{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix patterns will be left-biased, provided @x@ is.
......
......@@ -607,7 +607,7 @@ data Sig name
-- > {-# SPECIALISE f :: Int -> Int #-}
--
| SpecSig (Located name) -- Specialise a function or datatype ...
(LHsType name) -- ... to these types
[LHsType name] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
-- SPECIALISE, not SPECIALISE_INLINE
......@@ -630,7 +630,7 @@ deriving instance (DataId name) => Data (Sig name)
type LFixitySig name = Located (FixitySig name)
data FixitySig name = FixitySig (Located name) Fixity
data FixitySig name = FixitySig [Located name] Fixity
deriving (Data, Typeable)
-- | TsSpecPrags conveys pragmas from the type checker to the desugarer
......@@ -727,7 +727,8 @@ ppr_sig (TypeSig vars ty) = 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
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (ppr ty) inl)
ppr_sig (SpecSig var ty inl)
= pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf)
......@@ -750,7 +751,9 @@ pprPatSynSig ident _is_bidir tvs prov req ty
(Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
......
......@@ -12,6 +12,8 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Abstract syntax of global declarations.
--
......@@ -42,7 +44,7 @@ module HsDecls (
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
-- ** @RULE@ declarations
RuleDecl(..), LRuleDecl, RuleBndr(..),
RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
-- ** @VECTORISE@ declarations