compiler/types/Generics.lhs

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