Remove a redundant tabs warning kludge
[ghc.git] / compiler / vectorise / Vectorise / Type / TyConDecl.hs
1
2 module Vectorise.Type.TyConDecl (
3 vectTyConDecls
4 ) where
5
6 import Vectorise.Type.Type
7 import Vectorise.Monad
8 import BuildTyCl
9 import Class
10 import Type
11 import TyCon
12 import DataCon
13 import BasicTypes
14 import Var
15 import Name
16 import Outputable
17 import Util
18 import Control.Monad
19
20
21 -- |Vectorise some (possibly recursively defined) type constructors.
22 --
23 vectTyConDecls :: [TyCon] -> VM [TyCon]
24 vectTyConDecls tcs = fixV $ \tcs' ->
25 do { mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
26 ; mapM vectTyConDecl tcs
27 }
28
29 -- |Vectorise a single type constructor.
30 --
31 vectTyConDecl :: TyCon -> VM TyCon
32 vectTyConDecl tycon
33
34 -- Type constructor representing a type class
35 | Just cls <- tyConClass_maybe tycon
36 = do { unless (null $ classATs cls) $
37 cantVectorise "Associated types are not yet supported" (ppr cls)
38
39 -- make the name of the vectorised class tycon: "Class" --> "V:Class"
40 ; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
41
42 -- vectorise superclass constraint (types)
43 ; theta' <- mapM vectType (classSCTheta cls)
44
45 -- vectorise method selectors
46 ; let opItems = classOpItems cls
47 Just datacon = tyConSingleDataCon_maybe tycon
48 argTys = dataConRepArgTys datacon -- all selector types
49 opTys = drop (length argTys - length opItems) argTys -- only method types
50 ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
51
52 -- keep the original recursiveness flag
53 ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
54
55 -- construct the vectorised class (this also creates the class type constructors and its
56 -- data constructor)
57 --
58 -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
59 ; cls' <- liftDs $
60 buildClass
61 False -- include unfoldings on dictionary selectors
62 name' -- new name: "V:Class"
63 (tyConTyVars tycon) -- keep original type vars
64 theta' -- superclasses
65 (snd . classTvsFds $ cls) -- keep the original functional dependencies
66 [] -- no associated types (for the moment)
67 methods' -- method info
68 rec_flag -- whether recursive
69
70 -- the original dictionary constructor must map to the vectorised one
71 ; let tycon' = classTyCon cls'
72 Just datacon = tyConSingleDataCon_maybe tycon
73 Just datacon' = tyConSingleDataCon_maybe tycon'
74 ; defDataCon datacon datacon'
75
76 -- the original superclass and methods selectors must map to the vectorised ones
77 ; let selIds = classAllSelIds cls
78 selIds' = classAllSelIds cls'
79 ; zipWithM_ defGlobalVar selIds selIds'
80
81 -- return the type constructor of the vectorised class
82 ; return tycon'
83 }
84
85 -- Regular algebraic type constructor — for now, Haskell 2011-style only
86 | isAlgTyCon tycon
87 = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
88 cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
89
90 -- make the name of the vectorised class tycon
91 ; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
92
93 -- vectorise the data constructor of the class tycon
94 ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
95
96 -- keep the original recursiveness and GADT flags
97 ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
98 gadt_flag = isGadtSyntaxTyCon tycon
99
100 -- build the vectorised type constructor
101 ; liftDs $ buildAlgTyCon
102 name' -- new name
103 (tyConTyVars tycon) -- keep original type vars
104 [] -- no stupid theta
105 rhs' -- new constructor defs
106 rec_flag -- whether recursive
107 gadt_flag -- whether in GADT syntax
108 NoParentTyCon
109 Nothing -- not a family instance
110 }
111
112 -- some other crazy thing that we don't handle
113 | otherwise
114 = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon)
115
116 -- |Vectorise a class method. (Don't enter it into the vectorisation map yet.)
117 --
118 vectMethod :: Id -> DefMeth -> Type -> VM (Name, DefMethSpec, Type)
119 vectMethod id defMeth ty
120 = do { -- Vectorise the method type.
121 ; ty' <- vectType ty
122
123 -- Create a name for the vectorised method.
124 ; id' <- mkVectId id ty'
125
126 ; return (Var.varName id', defMethSpecOfDefMeth defMeth, ty')
127 }
128
129 -- |Vectorise the RHS of an algebraic type.
130 --
131 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
132 vectAlgTyConRhs tc (AbstractTyCon {})
133 = cantVectorise "Can't vectorise imported abstract type" (ppr tc)
134 vectAlgTyConRhs _tc DataFamilyTyCon
135 = return DataFamilyTyCon
136 vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
137 , is_enum = is_enum
138 })
139 = do { data_cons' <- mapM vectDataCon data_cons
140 ; zipWithM_ defDataCon data_cons data_cons'
141 ; return $ DataTyCon { data_cons = data_cons'
142 , is_enum = is_enum
143 }
144 }
145 vectAlgTyConRhs tc (NewTyCon {})
146 = cantVectorise noNewtypeErr (ppr tc)
147 where
148 noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
149
150 -- |Vectorise a data constructor by vectorising its argument and return types..
151 --
152 vectDataCon :: DataCon -> VM DataCon
153 vectDataCon dc
154 | not . null $ ex_tvs
155 = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc)
156 | not . null $ eq_spec
157 = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc)
158 | not . null $ dataConFieldLabels dc
159 = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc)
160 | not . null $ theta
161 = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc)
162 | otherwise
163 = do { name' <- mkLocalisedName mkVectDataConOcc name
164 ; tycon' <- vectTyCon tycon
165 ; arg_tys <- mapM vectType rep_arg_tys
166 ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
167 ; liftDs $ buildDataCon
168 name'
169 (dataConIsInfix dc) -- infix if the original is
170 (dataConStrictMarks dc) -- strictness as original constructor
171 [] -- no labelled fields for now
172 univ_tvs -- universally quantified vars
173 [] -- no existential tvs for now
174 [] -- no equalities for now
175 [] -- no context for now
176 arg_tys -- argument types
177 ret_ty -- return type
178 tycon' -- representation tycon
179 }
180 where
181 name = dataConName dc
182 rep_arg_tys = dataConRepArgTys dc
183 tycon = dataConTyCon dc
184 (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc