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