-- This functionality may be moved into GHC at some point, and then
-- we can use the GHC version (#if GHC version is new enough).
module Haddock.Convert ( tyThingToHsSynSig {- :: TyThing -> LHsDecl Name -} )
where
import HsSyn
import TcType ( tcSplitSigmaTy )
import TypeRep
import Type ( splitKindFunTys )
import Name
import HscTypes
import Var
import Class
import TyCon
import DataCon
import Id
import BasicTypes
import TysPrim ( alphaTyVars )
import Bag ( emptyBag )
import SrcLoc ( Located, noLoc )
import Maybe
-- the main function here! yay!
tyThingToHsSynSig :: TyThing -> LHsDecl Name
-- 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...
tyThingToHsSynSig (AnId i) = noLoc $
-- 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.
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.)
tyThingToHsSynSig (ATyCon tc) = noLoc $
TyClD (synifyTyCon tc)
-- a data-constructor alone just gets rendered as a function:
tyThingToHsSynSig (ADataCon dc) = noLoc $
SigD (TypeSig (synifyName dc)
(synifyType ImplicitizeForAll (dataConUserType dc)))
-- classes are just a little tedious
tyThingToHsSynSig (AClass cl) = noLoc $
TyClD $ ClassDecl
(synifyCtx (classSCTheta cl))
(synifyName cl)
(synifyTyVars (classTyVars cl))
(map (\ (l,r) -> noLoc
(map getName l, map getName r) ) $
snd $ classTvsFds cl)
(map (\i -> noLoc $ synifyIdSig DeleteTopLevelQuantification i)
(classMethods cl))
emptyBag --ignore default method definitions, they don't affect signature
(map synifyClassAT (classATs cl))
[] --we don't have any docs at this point
-- class associated-types are a subset of TyCon
-- (mainly only type/data-families)
synifyClassAT :: TyCon -> LTyClDecl Name
synifyClassAT tc = noLoc $ synifyTyCon tc
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
| isFunTyCon tc || isPrimTyCon tc =
TyData
-- arbitrary lie, they are neither algebraic data nor newtype:
DataType
-- no built-in type has any stupidTheta:
(noLoc [])
(synifyName tc)
-- tyConTyVars doesn't work on fun/prim, but we can make them up:
(zipWith
(\fakeTyVar realKind -> noLoc $
KindedTyVar (getName fakeTyVar) realKind)
alphaTyVars --a, b, c... which are unfortunately all kind *
(fst . splitKindFunTys $ tyConKind tc)
)
-- assume primitive types aren't members of data/newtype families:
Nothing
-- we have their kind accurately:
(Just (tyConKind tc))
-- no algebraic constructors:
[]
-- "deriving" needn't be specified:
Nothing
| isOpenSynTyCon tc =
case synTyConRhs tc of
OpenSynTyCon rhs_kind _ ->
TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
(Just rhs_kind)
_ -> error "synifyTyCon: impossible open type synonym?"
| isOpenTyCon tc = --(why no "isOpenAlgTyCon"?)
case algTyConRhs tc of
OpenTyCon _ ->
TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing --always kind '*'
_ -> error "synifyTyCon: impossible open data type?"
| otherwise =
-- (closed) type, newtype, and data
let
-- alg_ only applies to newtype/data
-- syn_ only applies to type
-- others apply to both
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)
-- 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.)
alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
-- "deriving" doesn't affect the signature, no need to specify any.
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
-- 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
qvars = if use_gadt_syntax
then synifyTyVars (dataConAllTyVars dc)
else synifyTyVars (dataConExTyVars dc)
-- skip any EqTheta, use 'orig'inal syntax
ctx = synifyCtx (dataConDictTheta dc)
linear_tys = zipWith (\ty strict ->
let tySyn = synifyType WithinType ty
in case strict of
MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
NotMarkedStrict ->
-- HsNoBang never appears, it's implied instead.
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
-- finally we get synifyDataCon's result!
in ConDecl name Implicit{-we don't know nor care-}
qvars ctx tys res_ty Nothing
synifyName :: NamedThing n => n -> Located Name
synifyName n = noLoc (getName n)
synifyIdSig :: SynifyTypeState -> Id -> Sig Name
synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i))
synifyCtx :: [PredType] -> LHsContext Name
synifyCtx ps = (\ps' -> noLoc ps') $
map synifyPred ps
where
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
-- IPName should be in class NamedThing...
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
else KindedTyVar name kind
--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 _ (PredTy{}) = --should never happen.
error "synifyType: PredTys are not, in themselves, source-level types."
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 =
let sTys = map (synifyType WithinType) tys
in noLoc $
HsTupleTy (tupleTyConBoxity tc) sTys
-- We could do the same for list types if we knew how to determine
-- whether the constructor was the list-constructor....
-- 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