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 to_pat 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_pat, 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                  InPat 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_pat, 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_pat, 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      VarPat to_arg,
 305      HsCase (HsVar to_arg)
 306             [mkSimpleHsAlt (ConPatIn inlDataCon_RDR (PrefixCon [l_to_pat])) l_to_body,
 307              mkSimpleHsAlt (ConPatIn inrDataCon_RDR (PrefixCon [r_to_pat])) r_to_body]
 308             generatedSrcLoc)
 309   where
 310     (l_datacons, r_datacons)            = splitInHalf datacons
 311     (l_from_alts, l_to_pat, l_to_body)  = mk_sum_stuff us' l_datacons
 312     (r_from_alts, r_to_pat, 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                   InPat RdrName,                        -- to_pat:
 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 --                               abc,
 337 --                               \<body-code> -> case abc of { a :*: bc ->
 338 --                                               case bc  of { b :*: c  ->
 339 --                                               <body-code> )
 340
 341 -- We need to use different uniques in the branches
 342 -- because the returned to_body_fns are nested.
 343 -- Hence the returned unqique-name supply
 344
 345 mk_prod_stuff us []             -- Unit case
 346   = (us+1,
 347      HsVar genUnitDataCon_RDR,
 348      SigPatIn (VarPat (mkGenericLocal us))
 349               (HsTyVar (getRdrName genUnitTyConName)),
 350         -- Give a signature to the pattern so we get
 351         --      data S a = Nil | S a
 352         --      toS = \x -> case x of { Inl (g :: Unit) -> Nil
 353         --                              Inr x -> S x }
 354         -- The (:: Unit) signature ensures that we'll infer the right
 355         -- type for toS. If we leave it out, the type is too polymorphic
 356
 357      \x -> x)
 358
 359 mk_prod_stuff us [arg_var]      -- Singleton case
 360   = (us, HsVar arg_var, VarPat arg_var, \x -> x)
 361
 362 mk_prod_stuff us arg_vars       -- Two or more
 363   = (us'',
 364      HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs,
 365      VarPat to_arg,
 366      \x -> HsCase (HsVar to_arg)
 367                   [mkSimpleHsAlt (ConPatIn crossDataCon_RDR (PrefixCon [l_to_pat, r_to_pat]))
 368                                  (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc)
 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
 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 -> HsExpr RdrName
 452 mkGenericRhs sel_id tyvar tycon
 453   = HsApp (toEP bimap) (HsVar (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 (HsVar from_RDR) (HsVar to_RDR)
 470         bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
 471
 472 type EPEnv = (TyVar,                    -- The class type variable
 473               EP (HsExpr 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 (HsExpr 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 (HsExpr 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 = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body,
 507          toEP   = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body }
 508   where
 509     from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP   ep1 `HsApp` HsVar b_RDR))
 510     to_body   = toEP   ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR))
 511
 512 -------------------
 513 bimapTuple eps
 514   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
 515          toEP   = mk_hs_lam [tuple_pat] to_body }
 516   where
 517     names       = takeList eps gs_RDR
 518     tuple_pat   = TuplePat (map VarPat names) Boxed
 519     eps_w_names = eps `zip` names
 520     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 521     from_body   = ExplicitTuple [fromEP ep `HsApp` HsVar 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 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc))
 529
 530 idEP :: EP (HsExpr RdrName)
 531 idEP = EP idexpr idexpr
 532      where
 533        idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR)
 534 \end{code}