ghc/compiler/types/Generics.lhs

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