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