diff options
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 403 |
1 files changed, 403 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs new file mode 100644 index 00000000..73ff3f1a --- /dev/null +++ b/haddock-api/src/Haddock/Convert.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE CPP, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Convert +-- Copyright : (c) Isaac Dupree 2009, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Conversion between TyThing and HsDecl. This functionality may be moved into +-- GHC at some point. +----------------------------------------------------------------------------- +module Haddock.Convert where +-- Some other functions turned out to be useful for converting +-- instance heads, which aren't TyThings, so just export everything. + + +import HsSyn +import TcType ( tcSplitSigmaTy ) +import TypeRep +import Type(isStrLitTy) +import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Name +import Var +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import FamInstEnv +import BasicTypes ( TupleSort(..) ) +import TysPrim ( alphaTyVars ) +import TysWiredIn ( listTyConName, eqTyCon ) +import PrelNames (ipClassName) +import Bag ( emptyBag ) +import Unique ( getUnique ) +import SrcLoc ( Located, noLoc, unLoc ) +import Data.List( partition ) +import Haddock.Types + + +-- the main function here! yay! +tyThingToLHsDecl :: TyThing -> LHsDecl Name +tyThingToLHsDecl t = noLoc $ case t of + -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. + -- Including built-in functions like seq. + -- foreign-imported functions could be represented with ForD + -- instead of SigD if we wanted... + -- + -- in a future code version we could turn idVarDetails = foreign-call + -- into a ForD instead of a SigD if we wanted. Haddock doesn't + -- need to care. + AnId i -> SigD (synifyIdSig ImplicitizeForAll i) + + -- 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 + | Just cl <- tyConClass_maybe tc -- classes are just a little tedious + -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a + extractFamilyDecl (FamDecl d) = noLoc d + extractFamilyDecl _ = + error "tyThingToLHsDecl: impossible associated tycon" + + atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] + atFamDecls = map extractFamilyDecl atTyClDecls in + TyClD $ ClassDecl + { tcdCtxt = synifyCtx (classSCTheta cl) + , tcdLName = synifyName cl + , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdFDs = map (\ (l,r) -> noLoc + (map getName l, map getName r) ) $ + snd $ classTvsFds cl + , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : + map (noLoc . synifyIdSig DeleteTopLevelQuantification) + (classMethods cl) + , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature + -- class associated-types are a subset of TyCon: + , tcdATs = atFamDecls + , tcdATDefs = [] --ignore associated type defaults + , tcdDocs = [] --we don't have any docs at this point + , tcdFVs = placeHolderNames } + | otherwise + -> TyClD (synifyTyCon Nothing tc) + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ACoAxiom ax -> synifyAxiom ax + + -- a data-constructor alone just gets rendered as a function: + AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] + (synifyType ImplicitizeForAll (dataConUserType dc))) + + AConLike (PatSynCon ps) -> +#if MIN_VERSION_ghc(7,8,3) + let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps +#else + let (_, _, (req_theta, prov_theta)) = patSynSig ps +#endif + in SigD $ PatSynSig (synifyName ps) +#if MIN_VERSION_ghc(7,8,3) + (fmap (synifyType WithinType) (patSynTyDetails ps)) + (synifyType WithinType res_ty) +#else + (fmap (synifyType WithinType) (patSynTyDetails ps)) + (synifyType WithinType (patSynType ps)) +#endif + (synifyCtx req_theta) + (synifyCtx prov_theta) + +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name +synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) + = let name = synifyName tc + typats = map (synifyType WithinType) args + hs_rhs = synifyType WithinType rhs + (kvs, tvs) = partition isKindVar tkvs + in TyFamInstEqn { tfie_tycon = name + , tfie_pats = HsWB { hswb_cts = typats + , hswb_kvs = map tyVarName kvs + , hswb_tvs = map tyVarName tvs } + , tfie_rhs = hs_rhs } + +synifyAxiom :: CoAxiom br -> HsDecl Name +synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) + | isOpenSynFamilyTyCon tc + , Just branch <- coAxiomSingleBranch_maybe ax + = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch + , tfid_fvs = placeHolderNames })) + + | Just ax' <- isClosedSynFamilyTyCon_maybe tc + , getUnique ax' == getUnique ax -- without the getUniques, type error + = TyClD (synifyTyCon (Just ax) tc) + + | otherwise + = error "synifyAxiom: closed/open family confusion" + +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name +synifyTyCon coax tc + | isFunTyCon tc || isPrimTyCon tc + = DataDecl { tcdLName = synifyName tc + , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: + let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind) + in HsQTvs { hsq_kvs = [] -- No kind polymorphism + , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + alphaTyVars --a, b, c... which are unfortunately all kind * + } + + , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + -- algebraic data nor newtype: + , dd_ctxt = noLoc [] + , dd_cType = Nothing + , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + -- we have their kind accurately: + , dd_cons = [] -- No constructors + , dd_derivs = Nothing } + , tcdFVs = placeHolderNames } + + | isSynFamilyTyCon tc + = case synTyConRhs_maybe tc of + Just rhs -> + let info = case rhs of + OpenSynFamilyTyCon -> OpenTypeFamily + ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> + ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches) + _ -> error "synifyTyCon: type/data family confusion" + in FamDecl (FamilyDecl { fdInfo = info + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) }) + Nothing -> error "synifyTyCon: impossible open type synonym?" + + | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?) + case algTyConRhs tc of + DataFamilyTyCon -> + FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) + Nothing) --always kind '*' + _ -> error "synifyTyCon: impossible open data type?" + | isSynTyCon tc + = case synTyConRhs_maybe tc of + Just (SynonymTyCon ty) -> + SynDecl { tcdLName = synifyName tc + , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdRhs = synifyType WithinType ty + , tcdFVs = placeHolderNames } + _ -> error "synifyTyCon: impossible synTyCon" + | otherwise = + -- (closed) newtype and data + let + alg_nd = if isNewTyCon tc then NewType else DataType + alg_ctx = synifyCtx (tyConStupidTheta tc) + name = case coax of + Just a -> synifyName a -- Data families are named according to their + -- CoAxioms, not their TyCons + _ -> synifyName tc + tyvars = synifyTyVars (tyConTyVars tc) + kindSig = Just (tyConKind tc) + -- The data constructors. + -- + -- Any data-constructors not exported from the module that *defines* the + -- type will not (cannot) be included. + -- + -- Very simple constructors, Haskell98 with no existentials or anything, + -- probably look nicer in non-GADT syntax. In source code, all constructors + -- must be declared with the same (GADT vs. not) syntax, and it probably + -- is less confusing to follow that principle for the documentation as well. + -- + -- There is no sensible infix-representation for GADT-syntax constructor + -- declarations. They cannot be made in source code, but we could end up + -- with some here in the case where some constructors use existentials. + -- That seems like an acceptable compromise (they'll just be documented + -- in prefix position), since, otherwise, the logic (at best) gets much more + -- complicated. (would use dataConIsInfix.) + use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) + cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) + -- "deriving" doesn't affect the signature, no need to specify any. + alg_deriv = Nothing + defn = HsDataDefn { dd_ND = alg_nd + , dd_ctxt = alg_ctx + , dd_cType = Nothing + , dd_kindSig = fmap synifyKindSig kindSig + , dd_cons = cons + , dd_derivs = alg_deriv } + in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn + , tcdFVs = placeHolderNames } + +-- User beware: it is your responsibility to pass True (use_gadt_syntax) +-- for any constructor that would be misrepresented by omitting its +-- result-type. +-- But you might want pass False in simple enough cases, +-- if you think it looks better. +synifyDataCon :: Bool -> DataCon -> LConDecl Name +synifyDataCon use_gadt_syntax dc = noLoc $ + let + -- dataConIsInfix allegedly tells us whether it was declared with + -- infix *syntax*. + use_infix_syntax = dataConIsInfix dc + use_named_field_syntax = not (null field_tys) + name = synifyName dc + -- con_qvars means a different thing depending on gadt-syntax + (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + + qvars = if use_gadt_syntax + then synifyTyVars (univ_tvs ++ ex_tvs) + else synifyTyVars ex_tvs + + -- skip any EqTheta, use 'orig'inal syntax + ctx = synifyCtx theta + + linear_tys = zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + src_bang = case bang of + HsUnpack {} -> HsUserBang (Just True) True + HsStrict -> HsUserBang (Just False) True + _ -> bang + in case src_bang of + HsNoBang -> tySyn + _ -> noLoc $ HsBangTy bang tySyn + -- HsNoBang never appears, it's implied instead. + ) + arg_tys (dataConStrictMarks dc) + field_tys = zipWith (\field synTy -> ConDeclField + (synifyName field) synTy Nothing) + (dataConFieldLabels dc) linear_tys + hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of + (True,True) -> error "synifyDataCon: contradiction!" + (True,False) -> RecCon field_tys + (False,False) -> PrefixCon linear_tys + (False,True) -> case linear_tys of + [a,b] -> InfixCon a b + _ -> error "synifyDataCon: infix with non-2 args?" + hs_res_ty = if use_gadt_syntax + then ResTyGADT (synifyType WithinType res_ty) + else ResTyH98 + -- finally we get synifyDataCon's result! + in ConDecl name Implicit{-we don't know nor care-} + qvars ctx hs_arg_tys hs_res_ty Nothing + False --we don't want any "deprecated GADT syntax" warnings! + + +synifyName :: NamedThing n => n -> Located Name +synifyName = noLoc . getName + + +synifyIdSig :: SynifyTypeState -> Id -> Sig Name +synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) + + +synifyCtx :: [PredType] -> LHsContext Name +synifyCtx = noLoc . map (synifyType WithinType) + + +synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs + , hsq_tvs = map synifyTyVar tvs } + where + (kvs, tvs) = partition isKindVar ktvs + synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv + +--states of what to do with foralls: +data SynifyTypeState + = WithinType + -- ^ normal situation. This is the safe one to use if you don't + -- quite understand what's going on. + | ImplicitizeForAll + -- ^ beginning of a function definition, in which, to make it look + -- less ugly, those rank-1 foralls are made implicit. + | DeleteTopLevelQuantification + -- ^ because in class methods the context is added to the type + -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) + -- which is rather sensible, + -- but we want to restore things to the source-syntax situation where + -- the defining class gets to quantify all its functions for free! + + +synifyType :: SynifyTypeState -> Type -> LHsType Name +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyConApp tc tys) + -- Use non-prefix tuple syntax where possible, because it looks nicer. + | isTupleTyCon tc, tyConArity tc == length tys = + noLoc $ HsTupleTy (case tupleTyConSort tc of + BoxedTuple -> HsBoxedTuple + ConstraintTuple -> HsConstraintTuple + UnboxedTuple -> HsUnboxedTuple) + (map (synifyType WithinType) tys) + -- ditto for lists + | getName tc == listTyConName, [ty] <- tys = + noLoc $ HsListTy (synifyType WithinType ty) + -- ditto for implicit parameter tycons + | tyConName tc == ipClassName + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) + -- and equalities + | tc == eqTyCon + , [ty1, ty2] <- tys + = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + -- Most TyCons: + | otherwise = + foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) + (noLoc $ HsTyVar (getName tc)) + (map (synifyType WithinType) tys) +synifyType _ (AppTy t1 t2) = let + s1 = synifyType WithinType t1 + s2 = synifyType WithinType t2 + in noLoc $ HsAppTy s1 s2 +synifyType _ (FunTy t1 t2) = let + s1 = synifyType WithinType t1 + s2 = synifyType WithinType t2 + in noLoc $ HsFunTy s1 s2 +synifyType s forallty@(ForAllTy _tv _ty) = + let (tvs, ctx, tau) = tcSplitSigmaTy forallty + in case s of + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau + _ -> let + forallPlicitness = case s of + WithinType -> Explicit + ImplicitizeForAll -> Implicit + _ -> error "synifyType: impossible case!!!" + sTvs = synifyTyVars tvs + sCtx = synifyCtx ctx + sTau = synifyType WithinType tau + in noLoc $ + HsForAllTy forallPlicitness sTvs sCtx sTau +synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t + +synifyTyLit :: TyLit -> HsTyLit +synifyTyLit (NumTyLit n) = HsNumTy n +synifyTyLit (StrTyLit s) = HsStrTy s + +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) = break (not . isKind) types + +-- Convert a family instance, this could be a type family or data family +synifyFamInst :: FamInst -> Bool -> InstHead Name +synifyFamInst fi opaque = + ( fi_fam fi + , map (unLoc . synifyType WithinType) ks + , map (unLoc . synifyType WithinType) ts + , case fi_flavor fi of + SynFamilyInst | opaque -> TypeInst Nothing + SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c + ) + where (ks,ts) = break (not . isKind) $ fi_tys fi |