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