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