diff options
| -rw-r--r-- | src/Haddock/Convert.hs | 62 | ||||
| -rw-r--r-- | src/Haddock/Interface/Rename.hs | 27 | ||||
| -rw-r--r-- | src/Haddock/Types.hs | 2 |
3 files changed, 21 insertions, 70 deletions
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 34de6775..c392cc1c 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -47,7 +47,22 @@ tyThingToLHsDecl t = noLoc $ case t of -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) - ATyCon tc -> TyClD (synifyTyCon tc) + ATyCon tc + | Just cl <- tyConClass_maybe tc -- classes are just a little tedious + -> TyClD $ ClassDecl + (synifyCtx (classSCTheta cl)) + (synifyName cl) + (synifyTyVars (classTyVars cl)) + (map (\ (l,r) -> noLoc + (map getName l, map getName r) ) $ + snd $ classTvsFds cl) + (map (noLoc . synifyIdSig DeleteTopLevelQuantification) + (classMethods cl)) + emptyBag --ignore default method definitions, they don't affect signature + (map synifyClassAT (classATs cl)) + [] --we don't have any docs at this point + | otherwise + -> TyClD (synifyTyCon tc) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -56,20 +71,6 @@ tyThingToLHsDecl t = noLoc $ case t of -- a data-constructor alone just gets rendered as a function: ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) - -- classes are just a little tedious - AClass cl -> - TyClD $ ClassDecl - (synifyCtx (classSCTheta cl)) - (synifyName cl) - (synifyTyVars (classTyVars cl)) - (map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ - snd $ classTvsFds cl) - (map (noLoc . synifyIdSig DeleteTopLevelQuantification) - (classMethods cl)) - emptyBag --ignore default method definitions, they don't affect signature - (map synifyClassAT (classATs cl)) - [] --we don't have any docs at this point -- class associated-types are a subset of TyCon @@ -224,25 +225,7 @@ synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name -synifyCtx = noLoc . map synifyPred - - -synifyPred :: PredType -> LHsPred Name -synifyPred (ClassP cls tys) = - let sTys = map (synifyType WithinType) tys - in noLoc $ - HsClassP (getName cls) sTys -synifyPred (IParam ip ty) = - let sTy = synifyType WithinType ty - -- IPName should be in class NamedThing... - in noLoc $ - HsIParam ip sTy -synifyPred (EqPred ty1 ty2) = - let - s1 = synifyType WithinType ty1 - s2 = synifyType WithinType ty2 - in noLoc $ - HsEqualP s1 s2 +synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name] @@ -273,8 +256,6 @@ data SynifyTypeState synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (PredTy{}) = --should never happen. - error "synifyType: PredTys are not, in themselves, source-level types." synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. @@ -310,12 +291,3 @@ synifyType s forallty@(ForAllTy _tv _ty) = sTau = synifyType WithinType tau in noLoc $ HsForAllTy forallPlicitness sTvs sCtx sTau - - -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> - ([HsPred Name], Name, [HsType Name]) -synifyInstHead (_, preds, cls, ts) = - ( map (unLoc . synifyPred) preds - , getName cls - , map (unLoc . synifyType WithinType) ts - ) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 2d5c899a..f5782eed 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -208,25 +208,6 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc -renameLPred :: LHsPred Name -> RnM (LHsPred DocName) -renameLPred = mapM renamePred - - -renamePred :: HsPred Name -> RnM (HsPred DocName) -renamePred (HsClassP name types) = do - name' <- rename name - types' <- mapM renameLType types - return (HsClassP name' types') -renamePred (HsEqualP type1 type2) = do - type1' <- renameLType type1 - type2' <- renameLType type2 - return (HsEqualP type1' type2') -renamePred (HsIParam (IPName name) t) = do - name' <- rename name - t' <- renameLType t - return (HsIParam (IPName name') t') - - renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType @@ -265,8 +246,6 @@ renameType t = case t of HsParTy ty -> return . HsParTy =<< renameLType ty - HsPredTy p -> return . HsPredTy =<< renamePred p - HsKindSig ty k -> do ty' <- renameLType ty return (HsKindSig ty' k) @@ -285,15 +264,15 @@ renameLTyVarBndr (L loc tv) = do return $ L loc (replaceTyVarName tv name') -renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName]) +renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do - context' <- mapM renameLPred context + context' <- mapM renameLType context return (L loc context') renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (preds, className, types) = do - preds' <- mapM renamePred preds + preds' <- mapM renameLType preds className' <- rename className types' <- mapM renameType types return (preds', className', types') diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index d82e3efd..fddafc1d 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -259,7 +259,7 @@ type DocInstance name = (InstHead name, Maybe (Doc name)) -- | The head of an instance. Consists of a context, a class name and a list -- of instance types. -type InstHead name = ([HsPred name], name, [HsType name]) +type InstHead name = ([HsType name], name, [HsType name]) ----------------------------------------------------------------------------- |