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