{-# 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 Bag ( emptyBag ) import BasicTypes ( TupleSort(..) ) import Class import CoAxiom import ConLike import Data.Either (lefts, rights) import Data.List( partition ) import DataCon import FamInstEnv import HsSyn import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn import PrelNames (ipClassName) import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) import Unique ( getUnique ) import Var import Haddock.Types import Haddock.Interface.Specialize -- the main function here! yay! tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) tyThingToLHsDecl t = 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 -> allOK $ 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 -> Either ErrMsg (LFamilyDecl a) extractFamilyDecl (FamDecl d) = return $ noLoc d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] atFamDecls = map extractFamilyDecl (rights atTyClDecls) tyClErrors = lefts atTyClDecls famDeclErrors = lefts atFamDecls in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl , tcdSigs = noLoc (MinimalSig mempty . 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 = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point , tcdFVs = placeHolderNamesTc } | otherwise -> synifyTyCon Nothing tc >>= allOK . TyClD -- 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 >>= allOK -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc)) []) AConLike (PatSynCon ps) -> let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps qtvs = univ_tvs ++ ex_tvs ty = mkFunTys arg_tys res_ty in allOK . SigD $ PatSynSig (synifyName ps) (Implicit, synifyTyVars qtvs) (synifyCtx req_theta) (synifyCtx prov_theta) (synifyType WithinType ty) where withErrs e x = return (e, x) allOK x = return (mempty, x) 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 TyFamEqn { tfe_tycon = name , tfe_pats = HsWB { hswb_cts = typats , hswb_kvs = map tyVarName kvs , hswb_tvs = map tyVarName tvs , hswb_wcs = [] } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax = return $ InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error = synifyTyCon (Just ax) tc >>= return . TyClD | otherwise = Left "synifyAxiom: closed/open family confusion" -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) synifyTyCon coax tc | isFunTyCon tc || isPrimTyCon tc = return $ 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 (noLoc (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 = placeHolderNamesTc } | isTypeFamilyTyCon tc = case famTyConFlav_maybe tc of Just rhs -> let info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) -> return $ ClosedTypeFamily $ Just $ brListMap (noLoc . synifyAxBranch tc) branches Nothing -> return $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily $ Just [] AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily Nothing in info >>= \i -> return (FamDecl (FamilyDecl { fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })) Nothing -> Left "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> return $ FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing) --always kind '*' _ -> Left "synifyTyCon: impossible open data type?" | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) , tcdRhs = synifyType WithinType ty , tcdFVs = placeHolderNamesTc } | 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) consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "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 case lefts consRaw of [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs -- 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 -> Either ErrMsg (LConDecl Name) synifyDataCon use_gadt_syntax dc = 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 {} -> HsSrcBang Nothing (Just True) (Just True) HsStrict -> HsSrcBang Nothing (Just False) (Just True) HsLazy -> HsSrcBang Nothing Nothing Nothing _ -> bang in case src_bang of (HsSrcBang _ Nothing Nothing) -> tySyn _ -> noLoc $ HsBangTy bang tySyn ) arg_tys (dataConSrcBangs dc) field_tys = zipWith (\field synTy -> noLoc $ ConDeclField [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) (False,False) -> return $ PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax then ResTyGADT noSrcSpan (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care qvars ctx hat hs_res_ty Nothing -- we don't want any "deprecated GADT syntax" warnings! False 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 (noLoc 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. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys = noLoc $ HsTupleTy (case sort 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 sTvs = synifyTyVars tvs sCtx = synifyCtx ctx sTau = synifyType WithinType tau mkHsForAllTy forallPlicitness = noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau WithinType -> mkHsForAllTy Explicit ImplicitizeForAll -> mkHsForAllTy Implicit synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n synifyTyLit (StrTyLit s) = HsStrTy mempty s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name 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) = break (not . isKind) 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 = 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) = break (not . isKind) $ fi_tys fi synifyTypes = map (unLoc. synifyType WithinType)