diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Specialize.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 21 |
1 files changed, 11 insertions, 10 deletions
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index ab719fe8..28bbf305 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name) specialize name details = everywhere $ mkT step where - step (HsTyVar (L _ name')) | name == name' = details + step (HsTyVar _ (L _ name')) | name == name' = details step typ = typ @@ -81,10 +81,10 @@ specializeSig :: forall name . (Eq name, DataId name, SetName name) -> Sig name -> Sig name specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}}) + TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}}) where true_type :: HsType name - true_type = unLoc (hswc_body (hsib_body typ)) + true_type = unLoc (hsSigWcType typ) typ' :: HsType name typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs @@ -123,7 +123,7 @@ sugar = sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) +sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name @@ -137,7 +137,7 @@ sugarTuples typ = where aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar (L _ name)) + aux apps (HsTyVar _ (L _ name)) | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps where name' = getName name @@ -149,7 +149,7 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb) +sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb where @@ -224,7 +224,7 @@ freeVariables = query term ctx = case cast term :: Maybe (HsType name) of Just (HsForAllTy bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar (L _ name)) + Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getNameRep name, ctx) _ -> (Set.empty, ctx) @@ -267,12 +267,13 @@ renameType (HsQualTy lctxt lt) = HsQualTy <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> located renameName name +renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr renameType (HsListTy lt) = HsListTy <$> renameLType lt renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt +renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt renameType (HsOpTy la lop lb) = HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb renameType (HsParTy lt) = HsParTy <$> renameLType lt @@ -284,8 +285,8 @@ renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt renameType t@(HsRecTy _) = pure t renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ph ltys) = - HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitListTy ip ph ltys) = + HsExplicitListTy ip ph <$> renameLTypes ltys renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t |