module Haddock.Convert where
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
tyThingToLHsDecl :: TyThing -> LHsDecl Name
tyThingToLHsDecl t = noLoc $ case t of
AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
ATyCon tc
| Just cl <- tyConClass_maybe tc
-> 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
, tcdATs = atFamDecls
, tcdATDefs = []
, tcdDocs = []
, tcdFVs = placeHolderNames }
| otherwise
-> TyClD (synifyTyCon Nothing tc)
ACoAxiom ax -> synifyAxiom ax
AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
in SigD $ PatSynSig (synifyName ps)
(fmap (synifyType WithinType) (patSynTyDetails ps))
(synifyType WithinType res_ty)
(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
= 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 =
let mk_hs_tv realKind fakeTyVar
= noLoc $ KindedTyVar (getName fakeTyVar)
(synifyKindSig realKind)
in HsQTvs { hsq_kvs = []
, hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
alphaTyVars
}
, tcdDataDefn = HsDataDefn { dd_ND = DataType
, dd_ctxt = noLoc []
, dd_cType = Nothing
, dd_kindSig = Just (synifyKindSig (tyConKind tc))
, dd_cons = []
, 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
=
case algTyConRhs tc of
DataFamilyTyCon ->
FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing)
_ -> 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 =
let
alg_nd = if isNewTyCon tc then NewType else DataType
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = case coax of
Just a -> synifyName a
_ -> synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
kindSig = Just (tyConKind tc)
use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
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 }
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
(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
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
)
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
in ConDecl name Implicit
qvars ctx hs_arg_tys hs_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 (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
data SynifyTypeState
= WithinType
| ImplicitizeForAll
| DeleteTopLevelQuantification
synifyType :: SynifyTypeState -> Type -> LHsType Name
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
synifyType _ (TyConApp tc tys)
| isTupleTyCon tc, tyConArity tc == length tys =
noLoc $ HsTupleTy (case tupleTyConSort tc of
BoxedTuple -> HsBoxedTuple
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType) tys)
| getName tc == listTyConName, [ty] <- tys =
noLoc $ HsListTy (synifyType WithinType ty)
| tyConName tc == ipClassName
, [name, ty] <- tys
, Just x <- isStrLitTy name
= noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
| tc == eqTyCon
, [ty1, ty2] <- tys
= noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
| 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
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