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