module Haddock.Convert where
import HsSyn
import TcType ( tcSplitSigmaTy )
import TypeRep
import Coercion ( splitKindFunTys, synTyConResKind )
import Name
import Var
import Class
import TyCon
import DataCon
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName )
import Bag ( emptyBag )
import SrcLoc ( Located, noLoc, unLoc )
tyThingToLHsDecl :: TyThing -> LHsDecl Name
tyThingToLHsDecl t = noLoc $ case t of
AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
ATyCon tc -> TyClD (synifyTyCon tc)
ADataCon dc -> SigD (TypeSig (synifyName dc)
(synifyType ImplicitizeForAll (dataConUserType dc)))
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
(map synifyClassAT (classATs cl))
[]
synifyClassAT :: TyCon -> LTyClDecl Name
synifyClassAT = noLoc . synifyTyCon
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
| isFunTyCon tc || isPrimTyCon tc =
TyData
DataType
(noLoc [])
(synifyName tc)
(zipWith
(\fakeTyVar realKind -> noLoc $
KindedTyVar (getName fakeTyVar) realKind)
alphaTyVars
(fst . splitKindFunTys $ tyConKind tc)
)
Nothing
(Just (tyConKind tc))
[]
Nothing
| isSynFamilyTyCon tc =
case synTyConRhs tc of
SynFamilyTyCon ->
TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
(Just (synTyConResKind tc))
_ -> error "synifyTyCon: impossible open type synonym?"
| isDataFamilyTyCon tc =
case algTyConRhs tc of
DataFamilyTyCon ->
TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing
_ -> error "synifyTyCon: impossible open data type?"
| otherwise =
let
alg_nd = if isNewTyCon tc then NewType else DataType
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
typats = case tyConFamInst_maybe tc of
Nothing -> Nothing
Just (_, indexes) -> Just (map (synifyType WithinType) indexes)
alg_kindSig = Just (tyConKind tc)
alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
alg_deriv = Nothing
syn_type = synifyType WithinType (synTyConType tc)
in if isSynTyCon tc
then TySynonym name tyvars typats syn_type
else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
synifyDataCon :: Bool -> DataCon -> LConDecl Name
synifyDataCon use_gadt_syntax dc = noLoc $
let
use_infix_syntax = dataConIsInfix dc
use_named_field_syntax = not (null field_tys)
name = synifyName dc
qvars = if use_gadt_syntax
then synifyTyVars (dataConAllTyVars dc)
else synifyTyVars (dataConExTyVars dc)
ctx = synifyCtx (dataConDictTheta dc)
linear_tys = zipWith (\ty bang ->
let tySyn = synifyType WithinType ty
in case bang of
HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn
HsNoBang -> tySyn
_ -> noLoc $ HsBangTy bang tySyn
)
(dataConOrigArgTys dc) (dataConStrictMarks dc)
field_tys = zipWith (\field synTy -> ConDeclField
(synifyName field) synTy Nothing)
(dataConFieldLabels dc) linear_tys
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?"
res_ty = if use_gadt_syntax
then ResTyGADT (synifyType WithinType (dataConOrigResTy dc))
else ResTyH98
in ConDecl name Implicit
qvars ctx tys res_ty Nothing
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 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
in noLoc $
HsIParam ip sTy
synifyPred (EqPred ty1 ty2) =
let
s1 = synifyType WithinType ty1
s2 = synifyType WithinType ty2
in noLoc $
HsEqualP s1 s2
synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
synifyTyVars = map synifyTyVar
where
synifyTyVar tv = noLoc $ let
kind = tyVarKind tv
name = getName tv
in if isLiftedTypeKind kind
then UserTyVar name placeHolderKind
else KindedTyVar name kind
data SynifyTypeState
= WithinType
| ImplicitizeForAll
| DeleteTopLevelQuantification
synifyType :: SynifyTypeState -> Type -> LHsType Name
synifyType _ (PredTy{}) =
error "synifyType: PredTys are not, in themselves, source-level types."
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
synifyType _ (TyConApp tc tys)
| isTupleTyCon tc, tyConArity tc == length tys =
noLoc $ HsTupleTy (tupleTyConBoxity tc) (map (synifyType WithinType) tys)
| getName tc == listTyConName, [ty] <- tys =
noLoc $ HsListTy (synifyType WithinType ty)
| 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
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
)