1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
| module Horrible ( tyThingToHsSyn ) where
import HsSyn
import TcType ( tcSplitSigmaTy )
import TypeRep
import Name
import HscTypes
import Var
import Class
import TyCon
import DataCon
import Id
import SrcLoc
import Maybe
import Bag (emptyBag)
ln :: NamedThing a => a -> b -> Located b
ln a = L (getSrcSpan a)
combineSrcSpanss :: [SrcSpan] -> SrcSpan
combineSrcSpanss [] = noSrcSpan
combineSrcSpanss ss = foldr1 combineSrcSpans ss
tyThingToHsSyn :: TyThing -> LHsDecl Name
tyThingToHsSyn (AnId i) = ln i $ SigD (synifyIdSig i)
tyThingToHsSyn (ATyCon tc) = ln tc $
TyClD (synifyTyCon tc)
tyThingToHsSyn (ADataCon dc) = ln dc $
SigD (TypeSig (synifyName dc) (synifyType (dataConUserType dc)))
tyThingToHsSyn (AClass cl) = ln cl $
TyClD $ ClassDecl
(synifyCtx (classSCTheta cl))
(synifyName cl)
(synifyTyVars (classTyVars cl))
(map (\ (l,r) -> L (combineSrcSpanss (map getSrcSpan (l++r)))
(map getName l, map getName r) ) $
snd $ classTvsFds cl)
(map (\i -> ln i $ synifyIdSig i) (classMethods cl))
emptyBag
[]
[]--bug(docs)
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
| isFunTyCon tc || isPrimTyCon tc = error "how to represent primitive tycons???"
synifyTyCon tc = let
alg_nd = if isNewTyCon tc then NewType else DataType
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
typats = case NoParentTyCon of
NoParentTyCon -> Nothing
ClassTyCon{} -> error "class tycon not expected here!"
FamilyTyCon _ indexes _ -> Just (map synifyType indexes)
alg_kindSig = Just (tyConKind tc)
alg_cons = map synifyDataCon (tyConDataCons tc)
alg_deriv = Nothing
syn_type = synifyType (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 :: DataCon -> LConDecl Name
synifyDataCon dc = ln dc $
let
name = synifyName dc
qvars = synifyTyVars (dataConAllTyVars dc)
ctx = synifyCtx (dataConDictTheta dc)
linear_tys = map synifyType (dataConOrigArgTys dc)
field_tys = zipWith (\field ty -> ConDeclField
(synifyName field) (synifyType ty) (error "docDataConField"))
(dataConFieldLabels dc) (dataConOrigArgTys dc) --docs?
tys = if null field_tys then PrefixCon linear_tys else RecCon field_tys
res_ty = ResTyGADT (synifyType (dataConOrigResTy dc))
in ConDecl name Implicit
qvars ctx tys res_ty (error "docDataCon")
synifyName :: NamedThing n => n -> Located Name
synifyName n = L (getSrcSpan n) (getName n)
synifyIdSig :: Id -> Sig Name
synifyIdSig i = TypeSig (synifyName i) (synifyType (varType i))
synifyCtx :: [PredType] -> LHsContext Name
synifyCtx ps = (\ps' -> L (combineSrcSpanss (map getLoc ps')) ps') $
map synifyPred ps where
synifyPred (ClassP cls tys) =
L noSrcSpan $
HsClassP (getName cls) (map synifyType tys)
synifyPred (IParam ip ty) =
L noSrcSpan $
HsIParam ip (synifyType ty)
synifyPred (EqPred ty1 ty2) =
L noSrcSpan $
HsEqualP (synifyType ty1) (synifyType ty2)
synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
synifyTyVars = map synifyTyVar where
synifyTyVar tv = ln tv $ let
kind = tyVarKind tv
name = getName tv
in if isLiftedTypeKind kind
then UserTyVar name
else KindedTyVar name kind
synifyType :: Type -> LHsType Name
synifyType (PredTy{}) = error "synifyType:?impossible??"
synifyType (TyVarTy tv) = ln tv $ HsTyVar (getName tv)
synifyType (TyConApp tc tys) =
foldl (\t1 t2 -> addCLoc t1 t2 (HsAppTy t1 t2))
(ln tc $ HsTyVar (getName tc))
(map synifyType tys)
synifyType (AppTy t1 t2) = L noSrcSpan $
HsAppTy (synifyType t1) (synifyType t2)
synifyType (FunTy t1 t2) = L noSrcSpan $
HsFunTy (synifyType t1) (synifyType t2)
synifyType forallty@(ForAllTy _tv _ty) = L noSrcSpan $
case tcSplitSigmaTy forallty of
(tvs, ctx, tau) ->
HsForAllTy
Explicit
(synifyTyVars tvs)
(synifyCtx ctx)
(synifyType tau)
|