diff options
Diffstat (limited to 'compiler/hsSyn/HsUtils.hs')
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 123 |
1 files changed, 98 insertions, 25 deletions
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index ca3cae5260..fb969ebff1 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -51,9 +51,11 @@ module HsUtils( mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types - mkHsAppTy, userHsTyVarBndrs, + mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + getAppsTyHead_maybe, hsTyGetAppHead_maybe, splitHsAppsTy, + getLHsInstDeclClass_maybe, -- Stmts mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, @@ -92,13 +94,12 @@ import HsTypes import HsLit import PlaceHolder -import TcType( tcSplitForAllTys, tcSplitPhiTy ) import TcEvidence import RdrName import Var -import Type( isPredTy ) -import Kind( isKind ) -import TypeRep +import TyCoRep +import Type ( filterOutInvisibleTypes ) +import TcType import DataCon import Name import NameSet @@ -171,6 +172,9 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) +mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name +mkHsAppTys = foldl mkHsAppTy + mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) @@ -335,10 +339,15 @@ mkHsStringPrimLit fs = HsStringPrim (unpackFS fs) (fastStringToByteString fs) ------------- -userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] +userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name] +-- Caller sets location +userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] + +userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name] -- Caller sets location userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] + {- ************************************************************************ * * @@ -548,24 +557,27 @@ toLHsSigWcType ty = mkLHsSigWcType (go ty) where go :: Type -> LHsType RdrName - go ty@(ForAllTy {}) - | (tvs, tau) <- tcSplitForAllTys ty - = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs - , hst_body = go tau }) - go ty@(FunTy arg _) + go ty@(ForAllTy (Anon arg) _) | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) , hst_body = go tau }) - go (FunTy arg res) = nlHsFunTy (go arg) (go res) + go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res) + go ty@(ForAllTy {}) + | (tvs, tau) <- tcSplitForAllTys ty + = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where - args' = filterOut isKind args - -- Source-language types have _implicit_ kind arguments, + args' = filterOutInvisibleTypes tc args + go (CastTy ty _) = go ty + go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) + + -- Source-language types have _invisible_ kind arguments, -- so we must remove them here (Trac #8563) go_tv :: TyVar -> LHsTyVarBndr RdrName @@ -956,20 +968,23 @@ 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) + -> record_gadt flds L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) - -> (map (L loc . unLoc) names ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) - flds) - remSeen' - = foldr (.) remSeen - [deleteBy ((==) `on` - rdrNameFieldOcc . unLoc) v - | v <- r'] - (ns, fs) = go remSeen' rs + -> record_gadt flds + _other -> (map (L loc . unLoc) names ++ ns, fs) where (ns, fs) = go remSeen rs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + where + (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) + where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) + remSeen' = foldr (.) remSeen + [deleteBy ((==) `on` + rdrNameFieldOcc . unLoc) v + | v <- r'] + (ns, fs) = go remSeen' rs + L loc (ConDeclH98 { con_name = name , con_details = RecCon flds }) -> ([L loc (unLoc name)] ++ ns, r' ++ fs) @@ -1080,3 +1095,61 @@ lPatImplicits = hs_lpat (unLoc fld) pat_explicit = maybe True (i<) (rec_dotdot fs)] details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2 + +{- +************************************************************************ +* * + Dealing with HsAppsTy +* * +************************************************************************ +-} + +-- | 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 tys = case splitHsAppsTy tys of + ([app1:apps], []) -> -- no symbols, some normal types + Just (mkHsAppTys app1 apps, []) + ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator + Just (L loc (HsTyVar (L loc op)), [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr]) + _ -> -- can't figure it out + Nothing + +-- | Splits a [HsAppType name] (the payload of an HsAppsTy) into regions of prefix +-- types (normal types) and infix operators. +-- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first +-- 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 = 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 (ty : acc) acc_non acc_sym rest + go acc acc_non acc_sym (HsAppInfix op : rest) + = go [] (reverse acc : acc_non) (op : acc_sym) rest + +-- retrieve the name of the "head" of a nested type application +-- somewhat like splitHsAppTys, but a little more thorough +-- used to examine the result of a GADT-like datacon, so it doesn't handle +-- *all* cases (like lists, tuples, (~), etc.) +hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +hsTyGetAppHead_maybe = go [] + where + go tys (L _ (HsTyVar ln)) = Just (ln, tys) + go tys (L _ (HsAppsTy apps)) + | Just (head, args) <- getAppsTyHead_maybe apps + = go (args ++ tys) head + go tys (L _ (HsAppTy l r)) = go (r : tys) l + go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys) + go tys (L _ (HsParTy t)) = go tys t + go tys (L _ (HsKindSig t _)) = go tys t + go _ _ = Nothing + +getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) + ; (cls, _) <- hsTyGetAppHead_maybe tau + ; return cls } |