compiler/types/Generics.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 module Generics ( canDoGenerics, mkTyConGenericBinds,
   7                   mkGenericRhs,
   8                   validGenericInstanceType, validGenericMethodType
   9     ) where
  10
  11
  12 import HsSyn
  13 import Type
  14 import TcHsSyn
  15 import TcType
  16 import DataCon
  17
  18 import TyCon
  19 import Name
  20 import OccName
  21 import RdrName
  22 import BasicTypes
  23 import Var
  24 import VarSet
  25 import Id
  26 import TysWiredIn
  27 import PrelNames
  28
  29 import SrcLoc
  30 import Util
  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   --    * lists
 194   --    * an arbitrary type not involving the class type variables
 195   --            e.g. this is ok:        forall b. Ord b => [b] -> a
 196   --                 where a is the class variable
 197 validGenericMethodType ty
 198   = valid tau
 199   where
 200     (local_tvs, _, tau) = tcSplitSigmaTy ty
 201
 202     valid ty
 203       | not (isTauTy ty) = False        -- Note [Higher ramk methods]
 204       | isTyVarTy ty     = True
 205       | no_tyvars_in_ty  = True
 206       | otherwise        = case tcSplitTyConApp_maybe ty of
 207                                 Just (tc,tys) -> valid_tycon tc && all valid tys
 208                                 Nothing       -> False
 209       where
 210         no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 211
 212     valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
 213         -- Compare bimapApp, below
 214 \end{code}
 215
 216
 217 %************************************************************************
 218 %*                                                                      *
 219 \subsection{Generating representation types}
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 \begin{code}
 224 canDoGenerics :: [DataCon] -> Bool
 225 -- Called on source-code data types, to see if we should generate
 226 -- generic functions for them.  (This info is recorded in the interface file for
 227 -- imported data types.)
 228
 229 canDoGenerics data_cons
 230   =  not (any bad_con data_cons)        -- See comment below
 231   && not (null data_cons)               -- No values of the type
 232   where
 233     bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
 234         -- If any of the constructor has an unboxed type as argument,
 235         -- then we can't build the embedding-projection pair, because
 236         -- it relies on instantiating *polymorphic* sum and product types
 237         -- at the argument types of the constructors
 238
 239         -- Nor can we do the job if it's an existential data constructor,
 240
 241         -- Nor if the args are polymorphic types (I don't think)
 242     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
 243 \end{code}
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection{Generating the RHS of a generic default method}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 \begin{code}
 252 type US = Int   -- Local unique supply, just a plain Int
 253 type FromAlt = (LPat RdrName, LHsExpr RdrName)
 254
 255 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
 256 mkTyConGenericBinds tycon
 257   = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
 258         `unionBags`
 259     unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
 260   where
 261     from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
 262     to_matches   = [mkSimpleHsAlt to_pat to_body]
 263     loc      = srcLocSpan (getSrcLoc tycon)
 264     datacons = tyConDataCons tycon
 265     (from_RDR, to_RDR) = mkGenericNames tycon
 266
 267     -- Recurse over the sum first
 268     from_alts :: [FromAlt]
 269     (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
 270     init_us = 1::Int            -- Unique supply
 271
 272 ----------------------------------------------------
 273 --      Dealing with sums
 274 ----------------------------------------------------
 275
 276 mk_sum_stuff :: US                      -- Base for generating unique names
 277              -> [DataCon]               -- The data constructors
 278              -> ([FromAlt],                             -- Alternatives for the T->Trep "from" function
 279                  InPat RdrName, LHsExpr RdrName)        -- Arg and body of the Trep->T "to" function
 280
 281 -- For example, given
 282 --      data T = C | D Int Int Int
 283 --
 284 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
 285 --                         case cd of { Inl u -> C;
 286 --                                      Inr abc -> case abc of { a :*: bc ->
 287 --                                                 case bc  of { b :*: c ->
 288 --                                                 D a b c }} },
 289 --                         cd)
 290
 291 mk_sum_stuff us [datacon]
 292    = ([from_alt], to_pat, to_body_fn app_exp)
 293    where
 294      n_args = dataConSourceArity datacon        -- Existentials already excluded
 295
 296      datacon_vars = map mkGenericLocal [us .. us+n_args-1]
 297      us'          = us + n_args
 298
 299      datacon_rdr  = getRdrName datacon
 300      app_exp      = nlHsVarApps datacon_rdr datacon_vars
 301      from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
 302
 303      (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
 304
 305 mk_sum_stuff us datacons
 306   = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
 307      nlVarPat to_arg,
 308      noLoc (HsCase (nlHsVar to_arg)
 309             (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
 310                            mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
 311   where
 312     (l_datacons, r_datacons)            = splitInHalf datacons
 313     (l_from_alts, l_to_pat, l_to_body)  = mk_sum_stuff us' l_datacons
 314     (r_from_alts, r_to_pat, r_to_body)  = mk_sum_stuff us' r_datacons
 315
 316     to_arg = mkGenericLocal us
 317     us'    = us+1
 318
 319     wrap :: RdrName -> [FromAlt] -> [FromAlt]
 320         -- Wrap an application of the Inl or Inr constructor round each alternative
 321     wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
 322
 323
 324 ----------------------------------------------------
 325 --      Dealing with products
 326 ----------------------------------------------------
 327 mk_prod_stuff :: US                     -- Base for unique names
 328               -> [RdrName]              -- arg-ids; args of the original user-defined constructor
 329                                         --      They are bound enclosing from_rhs
 330                                         --      Please bind these in the to_body_fn
 331               -> (US,                   -- Depleted unique-name supply
 332                   LHsExpr RdrName,                      -- from-rhs: puts together the representation from the arg_ids
 333                   InPat RdrName,                        -- to_pat:
 334                   LHsExpr RdrName -> LHsExpr RdrName)   -- to_body_fn: takes apart the representation
 335
 336 -- For example:
 337 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
 338 --                               abc,
 339 --                               \<body-code> -> case abc of { a :*: bc ->
 340 --                                               case bc  of { b :*: c  ->
 341 --                                               <body-code> )
 342
 343 -- We need to use different uniques in the branches
 344 -- because the returned to_body_fns are nested.
 345 -- Hence the returned unqique-name supply
 346
 347 mk_prod_stuff us []             -- Unit case
 348   = (us+1,
 349      nlHsVar genUnitDataCon_RDR,
 350      noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
 351                      (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
 352         -- Give a signature to the pattern so we get
 353         --      data S a = Nil | S a
 354         --      toS = \x -> case x of { Inl (g :: Unit) -> Nil
 355         --                              Inr x -> S x }
 356         -- The (:: Unit) signature ensures that we'll infer the right
 357         -- type for toS. If we leave it out, the type is too polymorphic
 358
 359      \x -> x)
 360
 361 mk_prod_stuff us [arg_var]      -- Singleton case
 362   = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
 363
 364 mk_prod_stuff us arg_vars       -- Two or more
 365   = (us'',
 366      nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
 367      nlVarPat to_arg,
 368 -- gaw 2004 FIX?
 369      \x -> noLoc (HsCase (nlHsVar to_arg)
 370                   (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
 371   where
 372     to_arg = mkGenericLocal us
 373     (l_arg_vars, r_arg_vars)                  = splitInHalf arg_vars
 374     (us',  l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
 375     (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
 376     pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
 377
 378 splitInHalf :: [a] -> ([a],[a])
 379 splitInHalf list = (left, right)
 380                  where
 381                    half  = length list `div` 2
 382                    left  = take half list
 383                    right = drop half list
 384
 385 mkGenericLocal :: US -> RdrName
 386 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 387
 388 mkGenericNames tycon
 389   = (from_RDR, to_RDR)
 390   where
 391     tc_name  = tyConName tycon
 392     tc_occ   = nameOccName tc_name
 393     tc_mod   = nameModule tc_name
 394     from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
 395     to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
 396 \end{code}
 397
 398 %************************************************************************
 399 %*                                                                      *
 400 \subsection{Generating the RHS of a generic default method}
 401 %*                                                                      *
 402 %************************************************************************
 403
 404 Generating the Generic default method.  Uses the bimaps to generate the
 405 actual method. All of this is rather incomplete, but it would be nice
 406 to make even this work.  Example
 407
 408         class Foo a where
 409           op :: Op a
 410
 411         instance Foo T
 412
 413 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
 414
 415         instance Foo T where
 416            op = <mkGenericRhs op a T>
 417
 418 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
 419
 420         toOp   :: Op Trep -> Op T
 421         fromOp :: Op T    -> Op Trep
 422
 423 (the bimap) and then fill in the RHS with
 424
 425         instance Foo T where
 426            op = toOp op
 427
 428 Remember, we're generating a RenamedHsExpr, so the result of all this
 429 will be fed to the type checker.  So the 'op' on the RHS will be
 430 at the representation type for T, Trep.
 431
 432
 433 Note [Polymorphic methods]
 434 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 435 Suppose the class op is polymorphic:
 436
 437         class Baz a where
 438           op :: forall b. Ord b => a -> b -> b
 439
 440 Then we can still generate a bimap with
 441
 442         toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
 443
 444 and fill in the instance decl thus
 445
 446         instance Foo T where
 447            op = toOp op
 448
 449 By the time the type checker has done its stuff we'll get
 450
 451         instance Foo T where
 452            op = \b. \dict::Ord b. toOp b (op Trep b dict)
 453
 454 Note [Higher rank methods]
 455 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 456 Higher-rank method types don't work, because we'd generate a bimap that
 457 needs impredicative polymorphism.  In principle that should be possible
 458 (with boxy types and all) but it would take a bit of working out.   Here's
 459 an example:
 460   class ChurchEncode k where
 461     match :: k -> z
 462           -> (forall a b z. a -> b -> z)  {- product -}
 463           -> (forall a   z. a -> z)       {- left -}
 464           -> (forall a   z. a -> z)       {- right -}
 465           -> z
 466
 467     match {| Unit    |} Unit      unit prod left right = unit
 468     match {| a :*: b |} (x :*: y) unit prod left right = prod x y
 469     match {| a :+: b |} (Inl l)   unit prod left right = left l
 470     match {| a :+: b |} (Inr r)   unit prod left right = right r
 471
 472 \begin{code}
 473 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
 474 mkGenericRhs sel_id tyvar tycon
 475   = ASSERT( isSingleton ctxt )  -- Checks shape of selector-id context
 476 --    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
 477     mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
 478   where
 479         -- Initialising the "Environment" with the from/to functions
 480         -- on the datatype (actually tycon) in question
 481         (from_RDR, to_RDR) = mkGenericNames tycon
 482
 483         -- Instantiate the selector type, and strip off its class context
 484         (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
 485
 486         -- Do it again!  This deals with the case where the method type
 487         -- is polymorphic -- see Note [Polymorphic methods] above
 488         (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 489
 490         -- Now we probably have a tycon in front
 491         -- of us, quite probably a FunTyCon.
 492         ep    = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
 493         bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
 494
 495 type EPEnv = (TyVar,                    -- The class type variable
 496               EP (LHsExpr RdrName),     -- The EP it maps to
 497               [TyVar]                   -- Other in-scope tyvars; they have an identity EP
 498              )
 499
 500 -------------------
 501 generate_bimap :: EPEnv
 502                -> Type
 503                -> EP (LHsExpr RdrName)
 504 -- Top level case - splitting the TyCon.
 505 generate_bimap env@(tv,ep,local_tvs) ty
 506   | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 507   = idEP        -- A constant type
 508
 509   | Just tv1 <- getTyVar_maybe ty
 510   = ASSERT( tv == tv1 ) ep                                      -- The class tyvar
 511
 512   | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
 513   = bimapTyCon tycon (map (generate_bimap env) ty_args)
 514
 515   | otherwise
 516   = pprPanic "generate_bimap" (ppr ty)
 517
 518 -------------------
 519 bimapTyCon :: TyCon -> [EP  (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 520 bimapTyCon tycon arg_eps
 521   | tycon == funTyCon       = bimapArrow arg_eps
 522   | tycon == listTyCon      = bimapList arg_eps
 523   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
 524   | otherwise               = pprPanic "bimapTyCon" (ppr tycon)
 525
 526 -------------------
 527 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
 528 bimapArrow [ep1, ep2]
 529   = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
 530          toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
 531   where
 532     from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP   ep1 `mkHsApp` nlHsVar b_RDR))
 533     to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
 534
 535 -------------------
 536 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
 537 bimapTuple eps
 538   = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
 539          toEP   = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
 540   where
 541     names       = takeList eps gs_RDR
 542     tuple_pat   = TuplePat (map nlVarPat names) Boxed placeHolderType
 543     eps_w_names = eps `zip` names
 544     to_body     = ExplicitTuple [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
 545     from_body   = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
 546
 547 -------------------
 548 -- bimapList :: EP a b -> EP [a] [b]
 549 bimapList [ep]
 550   = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
 551          toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
 552
 553 -------------------
 554 a_RDR   = mkVarUnqual FSLIT("a")
 555 b_RDR   = mkVarUnqual FSLIT("b")
 556 gs_RDR  = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
 557
 558 idEP :: EP (LHsExpr RdrName)
 559 idEP = EP idexpr idexpr
 560      where
 561        idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
 562 \end{code}