Ticket #3492: Convert.hs

File Convert.hs, 10.7 KB (added by simonmar, 5 years ago)
Line 
1
2-- This functionality may be moved into GHC at some point, and then
3-- we can use the GHC version (#if GHC version is new enough).
4module Haddock.Convert ( tyThingToHsSynSig {- :: TyThing -> LHsDecl Name -} )
5  where
6
7import HsSyn
8import TcType ( tcSplitSigmaTy )
9import TypeRep
10import Type ( splitKindFunTys )
11import Name
12import HscTypes
13import Var
14import Class
15import TyCon
16import DataCon
17import Id
18import BasicTypes
19import TysPrim ( alphaTyVars )
20import Bag ( emptyBag )
21import SrcLoc ( Located, noLoc )
22import Maybe
23
24-- the main function here! yay!
25tyThingToHsSynSig :: TyThing -> LHsDecl Name
26-- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
27-- Including built-in functions like seq.
28-- foreign-imported functions could be represented with ForD
29-- instead of SigD if we wanted...
30tyThingToHsSynSig (AnId i) = noLoc $
31  -- in a future code version we could turn idVarDetails = foreign-call
32  -- into a ForD instead of a SigD if we wanted.  Haddock doesn't
33  -- need to care.
34  SigD (synifyIdSig ImplicitizeForAll i)
35-- type-constructors (e.g. Maybe) are complicated, put the definition
36-- later in the file (also it's used for class associated-types too.)
37tyThingToHsSynSig (ATyCon tc) = noLoc $
38  TyClD (synifyTyCon tc)
39-- a data-constructor alone just gets rendered as a function:
40tyThingToHsSynSig (ADataCon dc) = noLoc $
41  SigD (TypeSig (synifyName dc)
42       (synifyType ImplicitizeForAll (dataConUserType dc)))
43-- classes are just a little tedious
44tyThingToHsSynSig (AClass cl) = noLoc $
45  TyClD $ ClassDecl
46    (synifyCtx (classSCTheta cl))
47    (synifyName cl)
48    (synifyTyVars (classTyVars cl))
49    (map (\ (l,r) -> noLoc
50               (map getName l, map getName r) ) $
51       snd $ classTvsFds cl)
52    (map (\i -> noLoc $ synifyIdSig DeleteTopLevelQuantification i)
53         (classMethods cl))
54    emptyBag --ignore default method definitions, they don't affect signature
55    (map synifyClassAT (classATs cl))
56    [] --we don't have any docs at this point
57
58-- class associated-types are a subset of TyCon
59-- (mainly only type/data-families)
60synifyClassAT :: TyCon -> LTyClDecl Name
61synifyClassAT tc = noLoc $ synifyTyCon tc
62
63synifyTyCon :: TyCon -> TyClDecl Name
64synifyTyCon tc
65  | isFunTyCon tc || isPrimTyCon tc =
66    TyData
67      -- arbitrary lie, they are neither algebraic data nor newtype:
68      DataType
69      -- no built-in type has any stupidTheta:
70      (noLoc [])
71      (synifyName tc)
72      -- tyConTyVars doesn't work on fun/prim, but we can make them up:
73      (zipWith
74         (\fakeTyVar realKind -> noLoc $
75             KindedTyVar (getName fakeTyVar) realKind)
76         alphaTyVars --a, b, c... which are unfortunately all kind *
77         (fst . splitKindFunTys $ tyConKind tc)
78      )
79      -- assume primitive types aren't members of data/newtype families:
80      Nothing
81      -- we have their kind accurately:
82      (Just (tyConKind tc))
83      -- no algebraic constructors:
84      []
85      -- "deriving" needn't be specified:
86      Nothing
87  | isOpenSynTyCon tc =
88      case synTyConRhs tc of
89        OpenSynTyCon rhs_kind _ ->
90          TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
91               (Just rhs_kind)
92        _ -> error "synifyTyCon: impossible open type synonym?"
93  | isOpenTyCon tc = --(why no "isOpenAlgTyCon"?)
94      case algTyConRhs tc of
95        OpenTyCon _ ->
96          TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
97               Nothing --always kind '*'
98        _ -> error "synifyTyCon: impossible open data type?"
99  | otherwise =
100  -- (closed) type, newtype, and data
101  let
102  -- alg_ only applies to newtype/data
103  -- syn_ only applies to type
104  -- others apply to both
105  alg_nd = if isNewTyCon tc then NewType else DataType
106  alg_ctx = synifyCtx (tyConStupidTheta tc)
107  name = synifyName tc
108  tyvars = synifyTyVars (tyConTyVars tc)
109  typats = case tyConFamInst_maybe tc of
110     Nothing -> Nothing
111     Just (_, indexes) -> Just (map (synifyType WithinType) indexes)
112  alg_kindSig = Just (tyConKind tc)
113  -- The data constructors.
114  --
115  -- Any data-constructors not exported from the module that *defines* the
116  -- type will not (cannot) be included.
117  --
118  -- Very simple constructors, Haskell98 with no existentials or anything,
119  -- probably look nicer in non-GADT syntax.  In source code, all constructors
120  -- must be declared with the same (GADT vs. not) syntax, and it probably
121  -- is less confusing to follow that principle for the documentation as well.
122  --
123  -- There is no sensible infix-representation for GADT-syntax constructor
124  -- declarations.  They cannot be made in source code, but we could end up
125  -- with some here in the case where some constructors use existentials.
126  -- That seems like an acceptable compromise (they'll just be documented
127  -- in prefix position), since, otherwise, the logic (at best) gets much more
128  -- complicated. (would use dataConIsInfix.)
129  alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
130  alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
131  -- "deriving" doesn't affect the signature, no need to specify any.
132  alg_deriv = Nothing
133  syn_type = synifyType WithinType (synTyConType tc)
134 in if isSynTyCon tc
135  then TySynonym name tyvars typats syn_type
136  else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
137
138-- User beware: it is your responsibility to pass True (use_gadt_syntax)
139-- for any constructor that would be misrepresented by omitting its
140-- result-type.
141-- But you might want pass False in simple enough cases,
142-- if you think it looks better.
143synifyDataCon :: Bool -> DataCon -> LConDecl Name
144synifyDataCon use_gadt_syntax dc = noLoc $
145 let
146  -- dataConIsInfix allegedly tells us whether it was declared with
147  -- infix *syntax*.
148  use_infix_syntax = dataConIsInfix dc
149  use_named_field_syntax = not (null field_tys)
150  name = synifyName dc
151  -- con_qvars means a different thing depending on gadt-syntax
152  qvars = if use_gadt_syntax
153    then synifyTyVars (dataConAllTyVars dc)
154    else synifyTyVars (dataConExTyVars dc)
155  -- skip any EqTheta, use 'orig'inal syntax
156  ctx = synifyCtx (dataConDictTheta dc)
157  linear_tys = zipWith (\ty strict ->
158            let tySyn = synifyType WithinType ty
159            in case strict of
160                 MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
161                 MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
162                 NotMarkedStrict ->
163                      -- HsNoBang never appears, it's implied instead.
164                      tySyn
165          )
166          (dataConOrigArgTys dc) (dataConStrictMarks dc)
167  field_tys = zipWith (\field synTy -> ConDeclField
168                                           (synifyName field) synTy Nothing)
169                (dataConFieldLabels dc) linear_tys
170  tys = case (use_named_field_syntax, use_infix_syntax) of
171          (True,True) -> error "synifyDataCon: contradiction!"
172          (True,False) -> RecCon field_tys
173          (False,False) -> PrefixCon linear_tys
174          (False,True) -> case linear_tys of
175                           [a,b] -> InfixCon a b
176                           _ -> error "synifyDataCon: infix with non-2 args?"
177  res_ty = if use_gadt_syntax
178    then ResTyGADT (synifyType WithinType (dataConOrigResTy dc))
179    else ResTyH98
180 -- finally we get synifyDataCon's result!
181 in ConDecl name Implicit{-we don't know nor care-}
182      qvars ctx tys res_ty Nothing
183
184synifyName :: NamedThing n => n -> Located Name
185synifyName n = noLoc (getName n)
186
187synifyIdSig :: SynifyTypeState -> Id -> Sig Name
188synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i))
189
190
191synifyCtx :: [PredType] -> LHsContext Name
192synifyCtx ps = (\ps' -> noLoc ps') $
193    map synifyPred ps
194  where
195  synifyPred (ClassP cls tys) =
196    let sTys = map (synifyType WithinType) tys
197    in noLoc $
198        HsClassP (getName cls) sTys
199  synifyPred (IParam ip ty) =
200    let sTy = synifyType WithinType ty
201    -- IPName should be in class NamedThing...
202    in noLoc $
203      HsIParam ip sTy
204  synifyPred (EqPred ty1 ty2) =
205    let
206     s1 = synifyType WithinType ty1
207     s2 = synifyType WithinType ty2
208    in noLoc $
209      HsEqualP s1 s2
210
211synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
212synifyTyVars = map synifyTyVar
213  where
214    synifyTyVar tv = noLoc $ let
215      kind = tyVarKind tv
216      name = getName tv
217     in if isLiftedTypeKind kind
218        then UserTyVar name
219        else KindedTyVar name kind
220
221--states of what to do with foralls:
222data SynifyTypeState
223  = WithinType
224  -- ^ normal situation.  This is the safe one to use if you don't
225  -- quite understand what's going on.
226  | ImplicitizeForAll
227  -- ^ beginning of a function definition, in which, to make it look
228  --   less ugly, those rank-1 foralls are made implicit.
229  | DeleteTopLevelQuantification
230  -- ^ because in class methods the context is added to the type
231  --   (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
232  --   which is rather sensible,
233  --   but we want to restore things to the source-syntax situation where
234  --   the defining class gets to quantify all its functions for free!
235
236synifyType :: SynifyTypeState -> Type -> LHsType Name
237synifyType _ (PredTy{}) = --should never happen.
238  error "synifyType: PredTys are not, in themselves, source-level types."
239synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
240synifyType _ (TyConApp tc tys)
241  -- Use non-prefix tuple syntax where possible, because it looks nicer.
242  | isTupleTyCon tc && tyConArity tc == length tys =
243     let sTys = map (synifyType WithinType) tys
244     in noLoc $
245        HsTupleTy (tupleTyConBoxity tc) sTys
246  -- We could do the same for list types if we knew how to determine
247  -- whether the constructor was the list-constructor....
248  -- Most TyCons:
249  | otherwise =
250    foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
251      (noLoc $ HsTyVar (getName tc))
252      (map (synifyType WithinType) tys)
253synifyType _ (AppTy t1 t2) = let
254  s1 = synifyType WithinType t1
255  s2 = synifyType WithinType t2
256  in noLoc $ HsAppTy s1 s2
257synifyType _ (FunTy t1 t2) = let
258  s1 = synifyType WithinType t1
259  s2 = synifyType WithinType t2
260  in noLoc $ HsFunTy s1 s2
261synifyType s forallty@(ForAllTy _tv _ty) =
262  let (tvs, ctx, tau) = tcSplitSigmaTy forallty
263  in case s of
264    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
265    _ -> let
266      forallPlicitness = case s of
267              WithinType -> Explicit
268              ImplicitizeForAll -> Implicit
269              _ -> error "synifyType: impossible case!!!"
270      sTvs = synifyTyVars tvs
271      sCtx = synifyCtx ctx
272      sTau = synifyType WithinType tau
273     in noLoc $
274           HsForAllTy forallPlicitness sTvs sCtx sTau
275