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