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