ghc/compiler/types/Generics.lhs

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