diff options
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
-rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 60 |
1 files changed, 38 insertions, 22 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 2e28b0dd..bc293731 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,16 +22,13 @@ import Class import CoAxiom import ConLike import Data.Either (lefts, rights) -import Data.List( partition ) -import Data.Monoid (mempty) import DataCon import FamInstEnv -import Haddock.Types import HsSyn import Name import RdrName ( mkVarUnqual ) import PatSyn -import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) +import SrcLoc ( Located, noLoc, unLoc ) import TcType ( tcSplitSigmaTy ) import TyCon import Type @@ -43,6 +40,9 @@ import Unique ( getUnique ) import Util ( filterByList, filterOut ) import Var +import Haddock.Types +import Haddock.Interface.Specialize + -- the main function here! yay! @@ -99,7 +99,8 @@ tyThingToLHsDecl t = case t of (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps)) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType + (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -416,23 +417,38 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = - ( getName cls - , map (unLoc . synifyType WithinType) ks - , map (unLoc . synifyType WithinType) ts - , ClassInst $ map (unLoc . synifyType WithinType) preds - ) - where (ks,ts) = partitionInvisibles (classTyCon cls) id types +synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead + { ihdClsName = getName cls + , ihdKinds = map (unLoc . synifyType WithinType) ks + , ihdTypes = map (unLoc . synifyType WithinType) ts + , ihdInstType = ClassInst + { clsiCtx = map (unLoc . synifyType WithinType) preds + , clsiTyVars = synifyTyVars $ classTyVars cls + , clsiSigs = map synifyClsIdSig $ classMethods cls + , clsiAssocTys = do + (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + pure $ mkPseudoFamilyDecl fam + } + } + where + (ks,ts) = partitionInvisibles (classTyCon cls) id types + synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) -synifyFamInst fi opaque = - let fff = case fi_flavor fi of - SynFamilyInst | opaque -> return $ TypeInst Nothing - SynFamilyInst -> - return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi - DataFamilyInst c -> - synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst - in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks, - map (unLoc . synifyType WithinType) ts , f') - where (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi +synifyFamInst fi opaque = do + ityp' <- ityp $ fi_flavor fi + return InstHead + { ihdClsName = fi_fam fi + , ihdKinds = synifyTypes ks + , ihdTypes = synifyTypes ts + , ihdInstType = ityp' + } + where + ityp SynFamilyInst | opaque = return $ TypeInst Nothing + ityp SynFamilyInst = + return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + ityp (DataFamilyInst c) = + DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c + (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi + synifyTypes = map (unLoc. synifyType WithinType) |