Track specified/invisible more carefully.
[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 Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
9 import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName )
10 import OccName
11 import Class
12 import Type
13 import TyCon
14 import DataCon
15 import BasicTypes
16 import DynFlags
17 import Var
18 import Name
19 import Outputable
20 import Util
21 import Control.Monad
22
23
24 -- |Vectorise some (possibly recursively defined) type constructors.
25 --
26 vectTyConDecls :: [TyCon] -> VM [TyCon]
27 vectTyConDecls tcs = fixV $ \tcs' ->
28 do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
29 ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
30 ; zipWithM vectTyConDecl tcs names'
31 }
32
33 -- |Vectorise a single type constructor.
34 --
35 vectTyConDecl :: TyCon -> Name -> VM TyCon
36 vectTyConDecl tycon name'
37
38 -- Type constructor representing a type class
39 | Just cls <- tyConClass_maybe tycon
40 = do { unless (null $ classATs cls) $
41 do dflags <- getDynFlags
42 cantVectorise dflags "Associated types are not yet supported" (ppr cls)
43
44 -- vectorise superclass constraint (types)
45 ; theta' <- mapM vectType (classSCTheta cls)
46
47 -- vectorise method selectors
48 ; let opItems = classOpItems cls
49 Just datacon = tyConSingleDataCon_maybe tycon
50 argTys = dataConRepArgTys datacon -- all selector types
51 opTys = drop (length argTys - length opItems) argTys -- only method types
52 ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
53
54 -- keep the original recursiveness flag
55 ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
56
57 -- construct the vectorised class (this also creates the class type constructors and its
58 -- data constructor)
59 --
60 -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
61 ; cls' <- liftDs $
62 buildClass
63 name' -- new name: "V:Class"
64 (tyConTyVars tycon) -- keep original type vars
65 (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
66 theta' -- superclasses
67 (tyConBinders tycon) -- keep original kind
68 (snd . classTvsFds $ cls) -- keep the original functional dependencies
69 [] -- no associated types (for the moment)
70 methods' -- method info
71 (classMinimalDef cls) -- Inherit minimal complete definition from cls
72 rec_flag -- whether recursive
73
74 -- the original dictionary constructor must map to the vectorised one
75 ; let tycon' = classTyCon cls'
76 Just datacon = tyConSingleDataCon_maybe tycon
77 Just datacon' = tyConSingleDataCon_maybe tycon'
78 ; defDataCon datacon datacon'
79
80 -- the original superclass and methods selectors must map to the vectorised ones
81 ; let selIds = classAllSelIds cls
82 selIds' = classAllSelIds cls'
83 ; zipWithM_ defGlobalVar selIds selIds'
84
85 -- return the type constructor of the vectorised class
86 ; return tycon'
87 }
88
89 -- Regular algebraic type constructor — for now, Haskell 2011-style only
90 | isAlgTyCon tycon
91 = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
92 do dflags <- getDynFlags
93 cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
94
95 -- vectorise the data constructor of the class tycon
96 ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
97
98 -- keep the original recursiveness and GADT flags
99 ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
100 gadt_flag = isGadtSyntaxTyCon tycon
101
102 -- build the vectorised type constructor
103 ; tc_rep_name <- mkDerivedName mkTyConRepOcc name'
104 ; return $ mkAlgTyCon
105 name' -- new name
106 (tyConBinders tycon)
107 (tyConResKind tycon) -- keep original kind
108 (tyConTyVars tycon) -- keep original type vars
109 (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
110 Nothing
111 [] -- no stupid theta
112 rhs' -- new constructor defs
113 (VanillaAlgTyCon tc_rep_name)
114 rec_flag -- whether recursive
115 gadt_flag -- whether in GADT syntax
116 }
117
118 -- some other crazy thing that we don't handle
119 | otherwise
120 = do dflags <- getDynFlags
121 cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)
122
123 -- |Vectorise a class method. (Don't enter it into the vectorisation map yet.)
124 --
125 vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo
126 vectMethod id defMeth ty
127 = do { -- Vectorise the method type.
128 ; ty' <- vectType ty
129
130 -- Create a name for the vectorised method.
131 ; id' <- mkVectId id ty'
132
133 ; return (Var.varName id', ty', defMethSpecOfDefMeth defMeth)
134 }
135
136 -- |Vectorise the RHS of an algebraic type.
137 --
138 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
139 vectAlgTyConRhs tc (AbstractTyCon {})
140 = do dflags <- getDynFlags
141 cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
142 vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
143 , is_enum = is_enum
144 })
145 = do { data_cons' <- mapM vectDataCon data_cons
146 ; zipWithM_ defDataCon data_cons data_cons'
147 ; return $ DataTyCon { data_cons = data_cons'
148 , is_enum = is_enum
149 }
150 }
151
152 vectAlgTyConRhs tc (TupleTyCon { data_con = con })
153 = vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False })
154 -- I'm not certain this is what you want to do for tuples,
155 -- but it's the behaviour we had before I refactored the
156 -- representation of AlgTyConRhs to add tuples
157
158 vectAlgTyConRhs tc (NewTyCon {})
159 = do dflags <- getDynFlags
160 cantVectorise dflags noNewtypeErr (ppr tc)
161 where
162 noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
163
164 -- |Vectorise a data constructor by vectorising its argument and return types..
165 --
166 vectDataCon :: DataCon -> VM DataCon
167 vectDataCon dc
168 | not . null $ ex_tvs
169 = do dflags <- getDynFlags
170 cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)
171 | not . null $ eq_spec
172 = do dflags <- getDynFlags
173 cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)
174 | not . null $ dataConFieldLabels dc
175 = do dflags <- getDynFlags
176 cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)
177 | not . null $ theta
178 = do dflags <- getDynFlags
179 cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)
180 | otherwise
181 = do { name' <- mkLocalisedName mkVectDataConOcc name
182 ; tycon' <- vectTyCon tycon
183 ; arg_tys <- mapM vectType rep_arg_tys
184 ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
185 ; fam_envs <- readGEnv global_fam_inst_env
186 ; rep_nm <- liftDs $ newTyConRepName name'
187 ; liftDs $ buildDataCon fam_envs
188 name'
189 (dataConIsInfix dc) -- infix if the original is
190 rep_nm
191 (dataConSrcBangs dc) -- strictness as original constructor
192 (Just $ dataConImplBangs dc)
193 [] -- no labelled fields for now
194 univ_tvs univ_bndrs -- universally quantified vars
195 [] [] -- no existential tvs for now
196 [] -- no equalities for now
197 [] -- no context for now
198 arg_tys -- argument types
199 ret_ty -- return type
200 tycon' -- representation tycon
201 }
202 where
203 name = dataConName dc
204 rep_arg_tys = dataConRepArgTys dc
205 tycon = dataConTyCon dc
206 (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
207 univ_bndrs = dataConUnivTyBinders dc