ghc/compiler/types/Generics.lhs

   1 \begin{code}
   2 module Generics ( canDoGenerics, mkTyConGenericBinds,
   3                   mkGenericRhs,
   4                   validGenericInstanceType, validGenericMethodType
   5     ) where
   6
   7
   8 import HsSyn
   9 import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
  10                           isTyVarTy, getTyVar_maybe, funTyCon
  11                         )
  12 import TcType           ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy )
  13 import DataCon          ( DataCon, dataConOrigArgTys, isExistentialDataCon,
  14                           dataConSourceArity )
  15
  16 import TyCon            ( TyCon, tyConName, tyConDataCons,
  17                           tyConHasGenerics, isBoxedTupleTyCon
  18                         )
  19 import Name             ( nameModuleName, nameOccName, getSrcLoc )
  20 import OccName          ( mkGenOcc1, mkGenOcc2 )
  21 import RdrName          ( RdrName, getRdrName, mkVarUnqual, mkOrig )
  22 import BasicTypes       ( EP(..), Boxity(..) )
  23 import Var              ( TyVar )
  24 import VarSet           ( varSetElems )
  25 import Id               ( Id, idType )
  26 import PrelNames
  27
  28 import SrcLoc           ( generatedSrcLoc )
  29 import Util             ( takeList )
  30 import Outputable
  31 import FastString
  32
  33 #include "HsVersions.h"
  34 \end{code}
  35
  36 Roadmap of what's where in the Generics work.
  37 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  38
  39 Parser
  40 No real checks.
  41
  42 RnSource.rnHsType
  43   Checks that HsNumTy has a "1" in it.
  44
  45 TcInstDcls.mkGenericInstance:
  46   Checks for invalid type patterns, such as f {| Int |}
  47
  48 TcClassDcl.tcClassSig
  49   Checks for a method type that is too complicated;
  50         e.g. has for-alls or lists in it
  51   We could lift this restriction
  52
  53 TcClassDecl.mkDefMethRhs
  54   Checks that the instance type is simple, in an instance decl
  55   where we let the compiler fill in a generic method.
  56         e.g.  instance C (T Int)
  57         is not valid if C has generic methods.
  58
  59 TcClassDecl.checkGenericClassIsUnary
  60   Checks that we don't have generic methods in a multi-parameter class
  61
  62 TcClassDecl.checkDefaultBinds
  63   Checks that all the equations for a method in a class decl
  64   are generic, or all are non-generic
  65
  66
  67
  68 Checking that the type constructors which are present in Generic
  69 patterns (not Unit, this is done differently) is done in mk_inst_info
  70 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
  71 HsOpTy is tied to Generic definitions which is not a very good design
  72 feature, indeed a bug. However, the check is easy to move from
  73 tcHsType back to mk_inst_info and everything will be fine. Also see
  74 bug #5. [I don't think that this is the case anymore after SPJ's latest
  75 changes in that regard.  Delete this comment?  -=chak/7Jun2]
  76
  77 Generics.lhs
  78
  79 Making generic information to put into a tycon. Constructs the
  80 representation type, which, I think, are not used later. Perhaps it is
  81 worth removing them from the GI datatype. Although it does get used in
  82 the construction of conversion functions (internally).
  83
  84 TyCon.lhs
  85
  86 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
  87
  88 TysWiredIn.lhs
  89
  90 Defines generic and other type and data constructors.
  91
  92 This is sadly incomplete, but will be added to.
  93
  94
  95 Bugs & shortcomings of existing implementation:
  96 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  97
  98 2. Another pretty big bug I dscovered at the last minute when I was
  99 testing the code is that at the moment the type variable of the class
 100 is scoped over the entire declaration, including the patterns. For
 101 instance, if I have the following code,
 102
 103 class Er a where
 104  ...
 105   er {| Plus a b |} (Inl x) (Inl y) = er x y
 106   er {| Plus a b |} (Inr x) (Inr y) = er x y
 107   er {| Plus a b |} _ _ = False
 108
 109 and I print out the types of the generic patterns, I get the
 110 following.  Note that all the variable names for "a" are the same,
 111 while for "b" they are all different.
 112
 113 check_ty
 114     [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
 115      std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
 116      std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
 117
 118 This is a bug as if I change the code to
 119
 120  er {| Plus c b |} (Inl x)  (Inl y) = er x y
 121
 122 all the names come out to be different.
 123
 124 Thus, all the types (Plus a b) come out to be different, so I cannot
 125 compare them and test whether they are all the same and thus cannot
 126 return an error if the type variables are different.
 127
 128 Temporary fix/hack. I am not checking for this, I just assume they are
 129 the same, see line "check_ty = True" in TcInstDecls. When we resolve
 130 the issue with variables, though - I assume that we will make them to
 131 be the same in all the type patterns, jus uncomment the check and
 132 everything should work smoothly.
 133
 134 Hence, I have also left the rather silly construction of:
 135 * extracting all the type variables from all the types
 136 * putting them *all* into the environment
 137 * typechecking all the types
 138 * selecting one of them and using it as the instance_ty.
 139
 140 (the alternative is to make sure that all the types are the same,
 141 taking one, extracting its variables, putting them into the environment,
 142 type checking it, using it as the instance_ty)
 143
 144 6. What happens if we do not supply all of the generic patterns? At
 145 the moment, the compiler crashes with an error message "Non-exhaustive
 146 patterns in a generic declaration"
 147
 148
 149 What has not been addressed:
 150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 151
 152 Contexts. In the generated instance declarations for the 3 primitive
 153 type constructors, we need contexts. It is unclear what those should
 154 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
 155
 156 Type application. We have type application in expressions
 157 (essentially) on the lhs of an equation. Do we want to allow it on the
 158 RHS?
 159
 160 Scoping of type variables in a generic definition. At the moment, (see
 161 TcInstDecls) we extract the type variables inside the type patterns
 162 and add them to the environment. See my bug #2 above. This seems pretty
 163 important.
 164
 165
 166
 167 %************************************************************************
 168 %*                                                                      *
 169 \subsection{Getting the representation type out}
 170 %*                                                                      *
 171 %************************************************************************
 172
 173 \begin{code}
 174 validGenericInstanceType :: Type -> Bool
 175   -- Checks for validity of the type pattern in a generic
 176   -- declaration.  It's ok to have
 177   --    f {| a + b |} ...
 178   -- but it's not OK to have
 179   --    f {| a + Int |}
 180
 181 validGenericInstanceType inst_ty
 182   = case tcSplitTyConApp_maybe inst_ty of
 183         Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
 184         Nothing           ->  False
 185
 186 validGenericMethodType :: Type -> Bool
 187   -- At the moment we only allow method types built from
 188   --    * type variables
 189   --    * function arrow
 190   --    * boxed tuples
 191   --    * an arbitrary type not involving the class type variables
 192   --            e.g. this is ok:        forall b. Ord b => [b] -> a
 193   --                 where a is the class variable
 194 validGenericMethodType ty
 195   = valid tau
 196   where
 197     (local_tvs, _, tau) = tcSplitSigmaTy ty
 198
 199     valid ty
 200       | isTyVarTy ty    = True
 201       | no_tyvars_in_ty = True
 202       | otherwise       = case tcSplitTyConApp_maybe ty of
 203                                 Just (tc,tys) -> valid_tycon tc && all valid tys
 204                                 Nothing       -> False
 205       where
 206         no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 207
 208     valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
 209         -- Compare bimapApp, below
 210 \end{code}
 211
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection{Generating representation types}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 \begin{code}
 220 canDoGenerics :: [DataCon] -> Bool
 221 -- Called on source-code data types, to see if we should generate
 222 -- generic functions for them.  (This info is recorded in the interface file for
 223 -- imported data types.)
 224
 225 canDoGenerics data_cons
 226   =  not (any bad_con data_cons)        -- See comment below
 227   && not (null data_cons)               -- No values of the type
 228   where
 229     bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc
 230         -- If any of the constructor has an unboxed type as argument,
 231         -- then we can't build the embedding-projection pair, because
 232         -- it relies on instantiating *polymorphic* sum and product types
 233         -- at the argument types of the constructors
 234
 235         -- Nor can we do the job if it's an existential data constructor,
 236
 237         -- Nor if the args are polymorphic types (I don't think)
 238     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
 239 \end{code}
 240
 241 %************************************************************************
 242 %*                                                                      *
 243 \subsection{Generating the RHS of a generic default method}
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 \begin{code}
 248 type US = Int   -- Local unique supply, just a plain Int
 249 type FromAlt = (Pat RdrName, HsExpr RdrName)
 250
 251 mkTyConGenericBinds :: TyCon -> MonoBinds RdrName
 252 mkTyConGenericBinds tycon
 253   = FunMonoBind from_RDR False {- Not infix -}
 254                 [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
 255                 loc
 256         `AndMonoBinds`
 257     FunMonoBind to_RDR False
 258                 [mkSimpleHsAlt (VarPat to_arg) to_body] loc
 259   where
 260     loc      = getSrcLoc tycon
 261     datacons = tyConDataCons tycon
 262     (from_RDR, to_RDR) = mkGenericNames tycon
 263
 264     -- Recurse over the sum first
 265     from_alts :: [FromAlt]
 266     (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons
 267     init_us = 1::Int            -- Unique supply
 268
 269 ----------------------------------------------------
 270 --      Dealing with sums
 271 ----------------------------------------------------
 272
 273 mk_sum_stuff :: US                      -- Base for generating unique names
 274              -> [DataCon]               -- The data constructors
 275              -> ([FromAlt],                     -- Alternatives for the T->Trep "from" function
 276                  RdrName, HsExpr RdrName)       -- Arg and body of the Trep->T "to" function
 277
 278 -- For example, given
 279 --      data T = C | D Int Int Int
 280 --
 281 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
 282 --                         case cd of { Inl u -> C;
 283 --                                      Inr abc -> case abc of { a :*: bc ->
 284 --                                                 case bc  of { b :*: c ->
 285 --                                                 D a b c }} },
 286 --                         cd)
 287
 288 mk_sum_stuff us [datacon]
 289    = ([from_alt], to_arg, to_body_fn app_exp)
 290    where
 291      n_args = dataConSourceArity datacon        -- Existentials already excluded
 292
 293      datacon_vars = map mkGenericLocal [us .. us+n_args-1]
 294      us'          = us + n_args
 295
 296      datacon_rdr  = getRdrName datacon
 297      app_exp      = mkHsVarApps datacon_rdr datacon_vars
 298      from_alt     = (mkConPat datacon_rdr datacon_vars, from_alt_rhs)
 299
 300      (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars
 301
 302 mk_sum_stuff us datacons
 303   = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
 304      to_arg,
 305      HsCase (HsVar to_arg)
 306             [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body,
 307              mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body]
 308             generatedSrcLoc)
 309   where
 310     (l_datacons, r_datacons)            = splitInHalf datacons
 311     (l_from_alts, l_to_arg, l_to_body)  = mk_sum_stuff us' l_datacons
 312     (r_from_alts, r_to_arg, r_to_body)  = mk_sum_stuff us' r_datacons
 313
 314     to_arg = mkGenericLocal us
 315     us'    = us+1
 316
 317     wrap :: RdrName -> [FromAlt] -> [FromAlt]
 318         -- Wrap an application of the Inl or Inr constructor round each alternative
 319     wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts]
 320
 321
 322 ----------------------------------------------------
 323 --      Dealing with products
 324 ----------------------------------------------------
 325 mk_prod_stuff :: US                     -- Base for unique names
 326               -> [RdrName]              -- arg-ids; args of the original user-defined constructor
 327                                         --      They are bound enclosing from_rhs
 328                                         --      Please bind these in the to_body_fn
 329               -> (US,                   -- Depleted unique-name supply
 330                   HsExpr RdrName,                       -- from-rhs: puts together the representation from the arg_ids
 331                   RdrName,                              -- to_arg:
 332                   HsExpr RdrName -> HsExpr RdrName)     -- to_body_fn: takes apart the representation
 333
 334 -- For example:
 335 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
 336 --                               \x -> case abc of { a :*: bc ->
 337 --                                     case bc  of { b :*: c  ->
 338 --                                     x)
 339
 340 -- We need to use different uniques in the branches
 341 -- because the returned to_body_fns are nested.
 342 -- Hence the returned unqique-name supply
 343
 344 mk_prod_stuff us []             -- Unit case
 345   = (us+1,
 346      HsVar genUnitDataCon_RDR,
 347      mkGenericLocal us,
 348      \x -> x)
 349
 350 mk_prod_stuff us [arg_var]      -- Singleton case
 351   = (us, HsVar arg_var, arg_var, \x -> x)
 352
 353 mk_prod_stuff us arg_vars       -- Two or more
 354   = (us'',
 355      HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs,
 356      to_arg,
 357      \x -> HsCase (HsVar to_arg)
 358                   [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg])
 359                                  (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc)
 360   where
 361     to_arg = mkGenericLocal us
 362     (l_arg_vars, r_arg_vars)                  = splitInHalf arg_vars
 363     (us',  l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
 364     (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
 365
 366
 367 splitInHalf :: [a] -> ([a],[a])
 368 splitInHalf list = (left, right)
 369                  where
 370                    half  = length list `div` 2
 371                    left  = take half list
 372                    right = drop half list
 373
 374 mkGenericLocal :: US -> RdrName
 375 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 376
 377 mkGenericNames tycon
 378   = (from_RDR, to_RDR)
 379   where
 380     tc_name  = tyConName tycon
 381     tc_occ   = nameOccName tc_name
 382     tc_mod   = nameModuleName tc_name
 383     from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
 384     to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
 385 \end{code}
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{Generating the RHS of a generic default method}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 Generating the Generic default method.  Uses the bimaps to generate the
 394 actual method. All of this is rather incomplete, but it would be nice
 395 to make even this work.  Example
 396
 397         class Foo a where
 398           op :: Op a
 399
 400         instance Foo T
 401
 402 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
 403
 404         instance Foo T where
 405            op = <mkGenericRhs op a T>
 406
 407 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
 408
 409         toOp   :: Op Trep -> Op T
 410         fromOp :: Op T    -> Op Trep
 411
 412 (the bimap) and then fill in the RHS with
 413
 414         instance Foo T where
 415            op = toOp op
 416
 417 Remember, we're generating a RenamedHsExpr, so the result of all this
 418 will be fed to the type checker.  So the 'op' on the RHS will be
 419 at the representation type for T, Trep.
 420
 421
 422 A note about polymorphism.  Suppose the class op is polymorphic:
 423
 424         class Baz a where
 425           op :: forall b. Ord b => a -> b -> b
 426
 427 Then we can still generate a bimap with
 428
 429         toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
 430
 431 and fill in the instance decl thus
 432
 433         instance Foo T where
 434            op = toOp op
 435
 436 By the time the type checker has done its stuff we'll get
 437
 438         instance Foo T where
 439            op = \b. \dict::Ord b. toOp b (op Trep b dict)
 440
 441 \begin{code}
 442 mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName
 443 mkGenericRhs sel_id tyvar tycon
 444   = HsApp (toEP bimap) (HsVar (getRdrName sel_id))
 445   where
 446         -- Initialising the "Environment" with the from/to functions
 447         -- on the datatype (actually tycon) in question
 448         (from_RDR, to_RDR) = mkGenericNames tycon
 449
 450         -- Takes out the ForAll and the Class restrictions
 451         -- in front of the type of the method.
 452         (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
 453
 454         -- Do it again!  This deals with the case where the method type
 455         -- is polymorphic -- see notes above
 456         (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 457
 458         -- Now we probably have a tycon in front
 459         -- of us, quite probably a FunTyCon.
 460         ep    = EP (HsVar from_RDR) (HsVar to_RDR)
 461         bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
 462
 463 type EPEnv = (TyVar,                    -- The class type variable
 464               EP (HsExpr RdrName),      -- The EP it maps to
 465               [TyVar]                   -- Other in-scope tyvars; they have an identity EP
 466              )
 467
 468 -------------------
 469 generate_bimap :: EPEnv
 470                -> Type
 471                -> EP (HsExpr RdrName)
 472 -- Top level case - splitting the TyCon.
 473 generate_bimap env@(tv,ep,local_tvs) ty
 474   = case getTyVar_maybe ty of
 475         Just tv1 |  tv == tv1 -> ep                             -- The class tyvar
 476                  |  otherwise -> ASSERT( tv1 `elem` local_tvs)  -- One of the polymorphic tyvars of the method
 477                                  idEP
 478         Nothing  -> bimapApp env (tcSplitTyConApp_maybe ty)
 479
 480 -------------------
 481 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName)
 482 bimapApp env Nothing                = panic "TcClassDecl: Type Application!"
 483 bimapApp env (Just (tycon, ty_args))
 484   | tycon == funTyCon       = bimapArrow arg_eps
 485   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
 486   | otherwise               =   -- Otherwise validGenericMethodType will
 487                                 -- have checked that the type is a constant type
 488                               ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
 489                               idEP
 490     where
 491       arg_eps = map (generate_bimap env) ty_args
 492       (_,_,local_tvs) = env
 493
 494 -------------------
 495 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
 496 bimapArrow [ep1, ep2]
 497   = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body,
 498          toEP   = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body }
 499   where
 500     from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP   ep1 `HsApp` HsVar b_RDR))
 501     to_body   = toEP   ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR))
 502
 503 -------------------
 504 bimapTuple eps
 505   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
 506          toEP   = mk_hs_lam [tuple_pat] to_body }
 507   where
 508     names       = takeList eps gs_RDR
 509     tuple_pat   = TuplePat (map VarPat names) Boxed
 510     eps_w_names = eps `zip` names
 511     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 512     from_body   = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 513
 514 -------------------
 515 a_RDR   = mkVarUnqual FSLIT("a")
 516 b_RDR   = mkVarUnqual FSLIT("b")
 517 gs_RDR  = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
 518
 519 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc))
 520
 521 idEP :: EP (HsExpr RdrName)
 522 idEP = EP idexpr idexpr
 523      where
 524        idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR)
 525 \end{code}