a2ded63da92e5f11fdc5682b89b89179512cfc01
[ghc.git] / compiler / types / Generics.lhs
1 %
2 % (c) The University of Glasgow 2011
3 %
4
5 \begin{code}
6
7 module Generics ( canDoGenerics,
8                   mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
9                   MetaTyCons(..), metaTyCons2TyCons
10     ) where
11
12
13 import HsSyn
14 import Type
15 import TcType
16 import DataCon
17
18 import TyCon
19 import Name hiding (varName)
20 import Module (Module, moduleName, moduleNameString)
21 import IfaceEnv (newGlobalBinder)
22 import RdrName
23 import BasicTypes
24 import TysWiredIn
25 import PrelNames
26
27 -- For generation of representation types
28 import TcEnv (tcLookupTyCon)
29 import TcRnMonad
30 import HscTypes
31 import BuildTyCl
32
33 import SrcLoc
34 import Bag
35 import Outputable 
36 import FastString
37
38 #include "HsVersions.h"
39 \end{code}
40
41 %************************************************************************
42 %*                                                                      *
43 \subsection{Generating representation types}
44 %*                                                                      *
45 %************************************************************************
46
47 \begin{code}
48 canDoGenerics :: TyCon -> Maybe SDoc
49 -- Called on source-code data types, to see if we should generate
50 -- generic functions for them.
51 -- Nothing == yes
52 -- Just s  == no, because of `s`
53
54 canDoGenerics tycon
55   =  mergeErrors (
56           -- We do not support datatypes with context
57               (if (not (null (tyConStupidTheta tycon)))
58                 then (Just (ppr tycon <+> text "must not have a datatype context"))
59                 else Nothing)
60           -- We don't like type families
61             : (if (isFamilyTyCon tycon)
62                 then (Just (ppr tycon <+> text "must not be a family instance"))
63                 else Nothing)
64           -- See comment below
65             : (map bad_con (tyConDataCons tycon)))
66   where
67         -- If any of the constructor has an unboxed type as argument,
68         -- then we can't build the embedding-projection pair, because
69         -- it relies on instantiating *polymorphic* sum and product types
70         -- at the argument types of the constructors
71     bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
72                   then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
73                   else (if (not (isVanillaDataCon dc))
74                           then (Just (ppr dc <+> text "must be a vanilla data constructor"))
75                           else Nothing)
76
77         -- Nor can we do the job if it's an existential data constructor,
78         -- Nor if the args are polymorphic types (I don't think)
79     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
80     
81     mergeErrors :: [Maybe SDoc] -> Maybe SDoc
82     mergeErrors []           = Nothing
83     mergeErrors ((Just s):t) = case mergeErrors t of
84                                  Nothing -> Just s
85                                  Just s' -> Just (s <> text ", and" $$ s')
86     mergeErrors (Nothing :t) = mergeErrors t
87 \end{code}
88
89 %************************************************************************
90 %*                                                                      *
91 \subsection{Generating the RHS of a generic default method}
92 %*                                                                      *
93 %************************************************************************
94
95 \begin{code}
96 type US = Int   -- Local unique supply, just a plain Int
97 type Alt = (LPat RdrName, LHsExpr RdrName)
98
99 -- Bindings for the Generic instance
100 mkBindsRep :: TyCon -> LHsBinds RdrName
101 mkBindsRep tycon = 
102     unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
103   `unionBags`
104     unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
105       where
106         from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
107         to_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
108         loc           = srcLocSpan (getSrcLoc tycon)
109         datacons      = tyConDataCons tycon
110
111         -- Recurse over the sum first
112         from_alts, to_alts :: [Alt]
113         (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
114         
115 --------------------------------------------------------------------------------
116 -- The type instance synonym and synonym
117 --       type instance Rep (D a b) = Rep_D a b
118 --       type Rep_D a b = ...representation type for D ...
119 --------------------------------------------------------------------------------
120
121 tc_mkRepTyCon :: TyCon            -- The type to generate representation for
122                -> MetaTyCons      -- Metadata datatypes to refer to
123                -> Module          -- JPM TODO
124                -> TcM TyCon       -- Generated representation0 type
125 tc_mkRepTyCon tycon metaDts mod = 
126 -- Consider the example input tycon `D`, where data D a b = D_ a
127   do { -- `rep0` = GHC.Generics.Rep (type family)
128        rep0 <- tcLookupTyCon repTyConName
129
130        -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
131      ; rep0Ty <- tc_mkRepTy tycon metaDts
132     
133        -- `rep_name` is a name we generate for the synonym
134 --     ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
135      ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
136                      (nameSrcSpan (tyConName tycon))
137      ; let -- `tyvars` = [a,b]
138            tyvars  = tyConTyVars tycon
139
140            -- rep0Ty has kind * -> *
141            rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
142
143            -- `appT` = D a b
144            appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
145
146      ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
147                      NoParentTyCon (Just (rep0, appT)) }
148
149
150
151 --------------------------------------------------------------------------------
152 -- Type representation
153 --------------------------------------------------------------------------------
154
155 tc_mkRepTy :: -- The type to generate representation for
156                TyCon 
157                -- Metadata datatypes to refer to
158             -> MetaTyCons 
159                -- Generated representation0 type
160             -> TcM Type
161 tc_mkRepTy tycon metaDts = 
162   do
163     d1    <- tcLookupTyCon d1TyConName
164     c1    <- tcLookupTyCon c1TyConName
165     s1    <- tcLookupTyCon s1TyConName
166     nS1   <- tcLookupTyCon noSelTyConName
167     rec0  <- tcLookupTyCon rec0TyConName
168     par0  <- tcLookupTyCon par0TyConName
169     u1    <- tcLookupTyCon u1TyConName
170     v1    <- tcLookupTyCon v1TyConName
171     plus  <- tcLookupTyCon sumTyConName
172     times <- tcLookupTyCon prodTyConName
173     
174     let mkSum' a b = mkTyConApp plus  [a,b]
175         mkProd a b = mkTyConApp times [a,b]
176         mkRec0 a   = mkTyConApp rec0  [a]
177         mkPar0 a   = mkTyConApp par0  [a]
178         mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
179         mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a) 
180                                                  (null (dataConFieldLabels a))]
181         -- This field has no label
182         mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
183         -- This field has a  label
184         mkS False d a = mkTyConApp s1 [d, a]
185         
186         sumP [] = mkTyConTy v1
187         sumP l  = ASSERT (length metaCTyCons == length l)
188                     foldBal mkSum' [ mkC i d a
189                                    | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
190         -- The Bool is True if this constructor has labelled fields
191         prod :: Int -> [Type] -> Bool -> Type
192         prod i [] _ = ASSERT (length metaSTyCons > i)
193                         ASSERT (length (metaSTyCons !! i) == 0)
194                           mkTyConTy u1
195         prod i l b  = ASSERT (length metaSTyCons > i)
196                         ASSERT (length l == length (metaSTyCons !! i))
197                           foldBal mkProd [ arg d t b
198                                          | (d,t) <- zip (metaSTyCons !! i) l ]
199         
200         arg :: Type -> Type -> Bool -> Type
201         arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
202         -- Argument is not a type variable, use Rec0
203         recOrPar t Nothing  = mkRec0 t
204         -- Argument is a type variable, use Par0
205         recOrPar t (Just _) = mkPar0 t
206         
207         metaDTyCon  = mkTyConTy (metaD metaDts)
208         metaCTyCons = map mkTyConTy (metaC metaDts)
209         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
210         
211     return (mkD tycon)
212
213 --------------------------------------------------------------------------------
214 -- Meta-information
215 --------------------------------------------------------------------------------
216
217 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
218                                metaD :: TyCon
219                                -- One meta datatype per constructor
220                              , metaC :: [TyCon]
221                                -- One meta datatype per selector per constructor
222                              , metaS :: [[TyCon]] }
223                              
224 instance Outputable MetaTyCons where
225   ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
226                                    
227 metaTyCons2TyCons :: MetaTyCons -> [TyCon]
228 metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
229
230
231 -- Bindings for Datatype, Constructor, and Selector instances
232 mkBindsMetaD :: FixityEnv -> TyCon 
233              -> ( LHsBinds RdrName      -- Datatype instance
234                 , [LHsBinds RdrName]    -- Constructor instances
235                 , [[LHsBinds RdrName]]) -- Selector instances
236 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
237       where
238         mkBag l = foldr1 unionBags 
239                     [ unitBag (L loc (mkFunBind (L loc name) matches)) 
240                         | (name, matches) <- l ]
241         dtBinds       = mkBag [ (datatypeName_RDR, dtName_matches)
242                               , (moduleName_RDR, moduleName_matches)]
243
244         allConBinds   = map conBinds datacons
245         conBinds c    = mkBag ( [ (conName_RDR, conName_matches c)]
246                               ++ ifElseEmpty (dataConIsInfix c)
247                                    [ (conFixity_RDR, conFixity_matches c) ]
248                               ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
249                                    [ (conIsRecord_RDR, conIsRecord_matches c) ]
250                               )
251
252         ifElseEmpty p x = if p then x else []
253         fixity c      = case lookupFixity fix_env (dataConName c) of
254                           Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
255                           Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
256                           Fixity n InfixN -> buildFix n notAssocDataCon_RDR
257         buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
258                                                      , nlHsIntLit (toInteger n)]
259
260         allSelBinds   = map (map selBinds) datasels
261         selBinds s    = mkBag [(selName_RDR, selName_matches s)]
262
263         loc           = srcLocSpan (getSrcLoc tycon)
264         mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
265         datacons      = tyConDataCons tycon
266         datasels      = map dataConFieldLabels datacons
267
268         dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName 
269                            $ tycon
270         moduleName_matches = mkStringLHS . moduleNameString . moduleName 
271                            . nameModule . tyConName $ tycon
272
273         conName_matches     c = mkStringLHS . showPpr . nameOccName
274                               . dataConName $ c
275         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
276         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
277
278         selName_matches     s = mkStringLHS (showPpr (nameOccName s))
279
280
281 --------------------------------------------------------------------------------
282 -- Dealing with sums
283 --------------------------------------------------------------------------------
284
285 mkSum :: US          -- Base for generating unique names
286       -> TyCon       -- The type constructor
287       -> [DataCon]   -- The data constructors
288       -> ([Alt],     -- Alternatives for the T->Trep "from" function
289           [Alt])     -- Alternatives for the Trep->T "to" function
290
291 -- Datatype without any constructors
292 mkSum _us tycon [] = ([from_alt], [to_alt])
293   where
294     from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
295     to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
296                -- These M1s are meta-information for the datatype
297     makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
298     errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
299     errMsgTo = "No values for empty datatype " ++ showPpr tycon
300
301 -- Datatype with at least one constructor
302 mkSum us _tycon datacons =
303   unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
304
305 -- Build the sum for a particular constructor
306 mk1Sum :: US        -- Base for generating unique names
307        -> Int       -- The index of this constructor
308        -> Int       -- Total number of constructors
309        -> DataCon   -- The data constructor
310        -> (Alt,     -- Alternative for the T->Trep "from" function
311            Alt)     -- Alternative for the Trep->T "to" function
312 mk1Sum us i n datacon = (from_alt, to_alt)
313   where
314     n_args = dataConSourceArity datacon -- Existentials already excluded
315
316     datacon_vars = map mkGenericLocal [us .. us+n_args-1]
317     us'          = us + n_args
318
319     datacon_rdr  = getRdrName datacon
320     app_exp      = nlHsVarApps datacon_rdr datacon_vars
321     
322     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
323     from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
324     
325     to_alt     = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
326                  -- These M1s are meta-information for the datatype
327     to_alt_rhs = app_exp
328
329 -- Generates the L1/R1 sum pattern
330 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
331 genLR_P i n p
332   | n == 0       = error "impossible"
333   | n == 1       = p
334   | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
335   | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
336                      where m = div n 2
337
338 -- Generates the L1/R1 sum expression
339 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
340 genLR_E i n e
341   | n == 0       = error "impossible"
342   | n == 1       = e
343   | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
344   | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
345                      where m = div n 2
346
347 --------------------------------------------------------------------------------
348 -- Dealing with products
349 --------------------------------------------------------------------------------
350
351 -- Build a product expression
352 mkProd_E :: US              -- Base for unique names
353          -> [RdrName]       -- List of variables matched on the lhs
354          -> LHsExpr RdrName -- Resulting product expression
355 mkProd_E _ []   = mkM1_E (nlHsVar u1DataCon_RDR)
356 mkProd_E _ vars = mkM1_E (foldBal prod appVars)
357                    -- These M1s are meta-information for the constructor
358   where
359     appVars = map wrapArg_E vars
360     prod a b = prodDataCon_RDR `nlHsApps` [a,b]
361
362 wrapArg_E :: RdrName -> LHsExpr RdrName
363 wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
364               -- This M1 is meta-information for the selector
365
366 -- Build a product pattern
367 mkProd_P :: US                  -- Base for unique names
368                -> [RdrName]     -- List of variables to match
369                -> LPat RdrName  -- Resulting product pattern
370 mkProd_P _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
371 mkProd_P _ vars = mkM1_P (foldBal prod appVars)
372                    -- These M1s are meta-information for the constructor
373   where
374     appVars = map wrapArg_P vars
375     prod a b = prodDataCon_RDR `nlConPat` [a,b]
376     
377 wrapArg_P :: RdrName -> LPat RdrName
378 wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
379               -- This M1 is meta-information for the selector
380
381 mkGenericLocal :: US -> RdrName
382 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
383
384 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
385 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
386
387 mkM1_P :: LPat RdrName -> LPat RdrName
388 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
389
390 -- | Variant of foldr1 for producing balanced lists
391 foldBal :: (a -> a -> a) -> [a] -> a
392 foldBal op = foldBal' op (error "foldBal: empty list")
393
394 foldBal' :: (a -> a -> a) -> a -> [a] -> a
395 foldBal' _  x []  = x
396 foldBal' _  _ [y] = y
397 foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
398                     in foldBal' op x a `op` foldBal' op x b
399
400 \end{code}