first working synify!

Isaac Dupree 2009-07-09 09:57:27 UTC

1module Horrible ( tyThingToHsSyn {- :: TyThing -> LHsDecl Name -} ) where
2
3import HsSyn
4import TcType ( tcSplitSigmaTy )
5import TypeRep
6import Name
7import HscTypes
8import Var
9import Class
10import TyCon
11import DataCon
12import Id
13import SrcLoc
14import Maybe
15import Bag (emptyBag)
16
17-- convenient, but probably someone will convince me to rename it
18ln :: NamedThing a => a -> b -> Located b
19ln a = L (getSrcSpan a)
20combineSrcSpanss :: [SrcSpan] -> SrcSpan
21combineSrcSpanss [] = noSrcSpan
22combineSrcSpanss ss = foldr1 combineSrcSpans ss
23
24-- the main function here! yay!
25tyThingToHsSyn :: TyThing -> LHsDecl Name
26tyThingToHsSyn (AnId i) = ln i $ {-hmm, not quite the same in 6.11
27 case globalIdVarDetails i of
28 --fixme specialize: FCallId -> ForD
29 _ -> -} SigD (synifyIdSig i)
30tyThingToHsSyn (ATyCon tc) = ln tc $
31 TyClD (synifyTyCon tc)
32-- a data-constructor alone just gets rendered as a function:
33tyThingToHsSyn (ADataCon dc) = ln dc $
34 SigD (TypeSig (synifyName dc) (synifyType (dataConUserType dc)))
35tyThingToHsSyn (AClass cl) = ln cl $
36 TyClD $ ClassDecl
37 (synifyCtx (classSCTheta cl))
38 (synifyName cl)
39 (synifyTyVars (classTyVars cl))
40 (map (\ (l,r) -> L (combineSrcSpanss (map getSrcSpan (l++r)))
41 (map getName l, map getName r) ) $
42 snd $ classTvsFds cl)
43 (map (\i -> ln i $ synifyIdSig i) (classMethods cl))
44 emptyBag --ignore default method definitions, they don't affect signature
45 []--bug( (classATs cl))
46 []--bug(docs)
47
48synifyTyCon :: TyCon -> TyClDecl Name
49synifyTyCon tc
50 | isFunTyCon tc || isPrimTyCon tc = error "how to represent primitive tycons???"
51synifyTyCon tc = let
52 alg_nd = if isNewTyCon tc then NewType else DataType
53 alg_ctx = synifyCtx (tyConStupidTheta tc)
54 name = synifyName tc
55 tyvars = synifyTyVars (tyConTyVars tc)
56 typats = case NoParentTyCon {-tyConParent tc-} of
57 NoParentTyCon -> Nothing
58 ClassTyCon{} -> error "class tycon not expected here!"
59 FamilyTyCon _ indexes _ -> Just (map synifyType indexes)
60 alg_kindSig = Just (tyConKind tc)
61 alg_cons = map synifyDataCon (tyConDataCons tc) --do we really *want* to *ignore* the unexported ones?
62 alg_deriv = Nothing --"deriving" doesn't affect the signature, no need to specify
63 syn_type = synifyType (synTyConType tc)
64 in if isSynTyCon tc
65 then TySynonym name tyvars typats syn_type
66 else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
67synifyDataCon :: DataCon -> LConDecl Name
68synifyDataCon dc = ln dc $
69 --pretend they're all GADT-syntax for now. Affects con_qvars and con_res
70 let
71 name = synifyName dc
72 qvars = synifyTyVars (dataConAllTyVars dc)
73 ctx = synifyCtx (dataConDictTheta dc) --skip EqTheta, use 'orig' syntax
74 linear_tys = map synifyType (dataConOrigArgTys dc)
75 field_tys = zipWith (\field ty -> ConDeclField
76 (synifyName field) (synifyType ty) (error "docDataConField"))
77 (dataConFieldLabels dc) (dataConOrigArgTys dc) --docs?
78 tys = if null field_tys then PrefixCon linear_tys else RecCon field_tys
79 --what about InfixCon?
80 res_ty = ResTyGADT (synifyType (dataConOrigResTy dc))
81
82 in ConDecl name Implicit{-we don't know nor care-}
83 qvars ctx tys res_ty (error "docDataCon")
84
85synifyName :: NamedThing n => n -> Located Name
86synifyName n = L (getSrcSpan n) (getName n)
87
88synifyIdSig :: Id -> Sig Name
89synifyIdSig i = TypeSig (synifyName i) (synifyType (varType i))
90
91
92synifyCtx :: [PredType] -> LHsContext Name
93synifyCtx ps = (\ps' -> L (combineSrcSpanss (map getLoc ps')) ps') $
94 map synifyPred ps where
95 synifyPred (ClassP cls tys) =
96 L noSrcSpan{-laziness-} $ --(combineSrcSpanss (getSrcSpan cls : map getSrcSpan tys)) $
97 HsClassP (getName cls) (map synifyType tys)
98 synifyPred (IParam ip ty) =
99 L noSrcSpan{-laziness-} $ --(combineSrcSpans (getSrcSpan (ipNameName ip{-hack, should be in NamedThing?-})) (getSrcSpan ty)) $
100 HsIParam ip (synifyType ty)
101 synifyPred (EqPred ty1 ty2) =
102 L noSrcSpan{-laziness-} $ --(combineSrcSpans (getSrcSpan ty1) (getSrcSpan ty2)) $
103 HsEqualP (synifyType ty1) (synifyType ty2)
104
105synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
106synifyTyVars = map synifyTyVar where
107 synifyTyVar tv = ln tv $ let
108 kind = tyVarKind tv
109 name = getName tv
110 in if isLiftedTypeKind kind
111 then UserTyVar name
112 else KindedTyVar name kind
113
114synifyType :: Type -> LHsType Name
115synifyType (PredTy{}) = error "synifyType:?impossible??"
116synifyType (TyVarTy tv) = ln tv $ HsTyVar (getName tv)
117synifyType (TyConApp tc tys) =
118-- case tc of
119-- TupleTyCon
120--Saturated tuple-types? List-types? Do they need to be made
121--into HsTupleTy boxity [...] and HsListTy ... ?
122 foldl (\t1 t2 -> addCLoc t1 t2 (HsAppTy t1 t2))
123 (ln tc $ HsTyVar (getName tc))
124 (map synifyType tys)
125synifyType (AppTy t1 t2) = L noSrcSpan{-laziness-} $
126 HsAppTy (synifyType t1) (synifyType t2)
127synifyType (FunTy t1 t2) = L noSrcSpan{-laziness-} $
128 HsFunTy (synifyType t1) (synifyType t2)
129synifyType forallty@(ForAllTy _tv _ty) = L noSrcSpan{-laziness-} $
130 case tcSplitSigmaTy forallty of
131 (tvs, ctx, tau) ->
132 HsForAllTy
133 Explicit{-we have no idea at this point-}
134 (synifyTyVars tvs)
135 (synifyCtx ctx)
136 (synifyType tau)
137
138
139