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 | module Horrible ( tyThingToHsSyn {- :: TyThing -> LHsDecl Name -} ) 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)
-- convenient, but probably someone will convince me to rename it
ln :: NamedThing a => a -> b -> Located b
ln a = L (getSrcSpan a)
combineSrcSpanss :: [SrcSpan] -> SrcSpan
combineSrcSpanss [] = noSrcSpan
combineSrcSpanss ss = foldr1 combineSrcSpans ss
-- the main function here! yay!
tyThingToHsSyn :: TyThing -> LHsDecl Name
tyThingToHsSyn (AnId i) = ln i $ {-hmm, not quite the same in 6.11
case globalIdVarDetails i of
--fixme specialize: FCallId -> ForD
_ -> -} SigD (synifyIdSig i)
tyThingToHsSyn (ATyCon tc) = ln tc $
TyClD (synifyTyCon tc)
-- a data-constructor alone just gets rendered as a function:
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 --ignore default method definitions, they don't affect signature
[]--bug( (classATs cl))
[]--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 {-tyConParent tc-} 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) --do we really *want* to *ignore* the unexported ones?
alg_deriv = Nothing --"deriving" doesn't affect the signature, no need to specify
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 $
--pretend they're all GADT-syntax for now. Affects con_qvars and con_res
let
name = synifyName dc
qvars = synifyTyVars (dataConAllTyVars dc)
ctx = synifyCtx (dataConDictTheta dc) --skip EqTheta, use 'orig' syntax
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
--what about InfixCon?
res_ty = ResTyGADT (synifyType (dataConOrigResTy dc))
in ConDecl name Implicit{-we don't know nor care-}
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{-laziness-} $ --(combineSrcSpanss (getSrcSpan cls : map getSrcSpan tys)) $
HsClassP (getName cls) (map synifyType tys)
synifyPred (IParam ip ty) =
L noSrcSpan{-laziness-} $ --(combineSrcSpans (getSrcSpan (ipNameName ip{-hack, should be in NamedThing?-})) (getSrcSpan ty)) $
HsIParam ip (synifyType ty)
synifyPred (EqPred ty1 ty2) =
L noSrcSpan{-laziness-} $ --(combineSrcSpans (getSrcSpan ty1) (getSrcSpan ty2)) $
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) =
-- case tc of
-- TupleTyCon
--Saturated tuple-types? List-types? Do they need to be made
--into HsTupleTy boxity [...] and HsListTy ... ?
foldl (\t1 t2 -> addCLoc t1 t2 (HsAppTy t1 t2))
(ln tc $ HsTyVar (getName tc))
(map synifyType tys)
synifyType (AppTy t1 t2) = L noSrcSpan{-laziness-} $
HsAppTy (synifyType t1) (synifyType t2)
synifyType (FunTy t1 t2) = L noSrcSpan{-laziness-} $
HsFunTy (synifyType t1) (synifyType t2)
synifyType forallty@(ForAllTy _tv _ty) = L noSrcSpan{-laziness-} $
case tcSplitSigmaTy forallty of
(tvs, ctx, tau) ->
HsForAllTy
Explicit{-we have no idea at this point-}
(synifyTyVars tvs)
(synifyCtx ctx)
(synifyType tau)
|