compiler/types/Generics.lhs

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