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 "must not have a datatype context"))
  56                 else Nothing)
  57           -- We don't like type families
  58             : (if (isFamilyTyCon tycon)
  59                 then (Just (ppr tycon <+> text "must not be 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 "must not have unlifted or polymorphic arguments"))
  70                   else (if (not (isVanillaDataCon dc))
  71                           then (Just (ppr dc <+> text "must be 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 <> text ", and" $$ 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 {-
 206                    (mkCoercionTyCon coName (tyConArity tycon)
 207                      (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
 208 -}
 209                    -- co : forall a b. Rep (D a b) ~ `rep0Ty` a b
 210                    (CoAxiom uniq2 coName tyvars (mkTyConApp rep0 appT) rep0Ty))
 211     return res
 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}