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