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, splitFunTys,
  12                           mkFunTy, isTyVarTy,
  13                           splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
  14                         )
  15
  16 import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
  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           ( isEmptyVarSet )
  27 import Id               ( Id, mkTemplateLocal, idType, idName,
  28                           mkTemplateLocalsNum, mkId
  29                         )
  30 import TysWiredIn       ( genericTyCons,
  31                           genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
  32                           inlDataCon, crossTyCon, crossDataCon
  33                         )
  34 import IdInfo           ( vanillaIdInfo, 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 validGenericMethodType ty = valid ty
 201
 202 valid ty
 203   | isTyVarTy ty = True
 204   | not (null arg_tys)  = all valid arg_tys && valid res_ty
 205   | no_tyvars_in_ty     = True
 206   | otherwise           = isBoxedTupleTyCon tc && all valid tys
 207   where
 208     (arg_tys, res_ty) = splitFunTys ty
 209     no_tyvars_in_ty   = isEmptyVarSet (tyVarsOfType ty)
 210     Just (tc,tys)     = splitTyConApp_maybe ty
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Generating representation types}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 \begin{code}
 221 mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
 222 -- mkTyConGenInfo is called twice
 223 --      once from TysWiredIn for Tuples
 224 --      once the typechecker TcTyDecls
 225 -- to generate generic types and conversion functions for all datatypes.
 226 --
 227 -- Must only be called with an algebraic type.
 228 --
 229 -- The two names are the names constructed by the renamer
 230 -- for the fromT and toT conversion functions.
 231
 232 mkTyConGenInfo tycon from_name to_name
 233   | null datacons       -- Abstractly imported types don't have
 234   = Nothing             -- to/from operations, (and should not need them)
 235
 236         -- If any of the constructor has an unboxed type as argument
 237         -- then we can't build the embedding-projection pair, because
 238         -- it relies on instantiating *polymorphic* sum and product types
 239         -- at the argument types of the constructors
 240   | any (any isUnLiftedType . dataConOrigArgTys) datacons
 241   = Nothing
 242
 243   | otherwise
 244   = Just (EP { fromEP = mkId from_name from_ty from_id_info,
 245                toEP   = mkId to_name   to_ty   to_id_info })
 246   where
 247     tyvars       = tyConTyVars tycon                    -- [a, b, c]
 248     datacons     = tyConDataConsIfAvailable tycon       -- [C, D]
 249     tycon_ty     = mkTyConApp tycon tyvar_tys           -- T a b c
 250     tyvar_tys    = mkTyVarTys tyvars
 251
 252     from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
 253     to_id_info   = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
 254
 255     from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
 256     to_ty   = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
 257
 258     (from_fn, to_fn, rep_ty)
 259         | isNewTyCon tycon
 260         = ( mkLams tyvars $ Lam x  $ Note (Coerce newrep_ty tycon_ty) (Var x),
 261             Var (dataConWrapId the_datacon),
 262             newrep_ty )
 263
 264         | otherwise
 265         = ( mkLams tyvars $ Lam x     $ Case (Var x) x from_alts,
 266             mkLams tyvars $ Lam rep_var to_inner,
 267             idType rep_var )
 268
 269     -- x :: T a b c
 270     x  = mkTemplateLocal 1 tycon_ty
 271
 272             ----------------------
 273             --  Newtypes only
 274     [the_datacon]  = datacons
 275     newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
 276
 277             ----------------------
 278             --  Non-newtypes only
 279     -- Recurse over the sum first
 280     -- The "2" is the first free unique
 281     (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
 282
 283
 284
 285 ----------------------------------------------------
 286 --      Dealing with sums
 287 ----------------------------------------------------
 288 mk_sum_stuff :: Int             -- Base for generating unique names
 289              -> [TyVar]         -- Type variables over which the tycon is abstracted
 290              -> [DataCon]       -- The data constructors
 291              -> ([Alt Id], CoreExpr, Id)
 292
 293 -- For example, given
 294 --      data T = C | D Int Int Int
 295 --
 296 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
 297 --                         case cd of { Inl u -> C;
 298 --                                      Inr abc -> case abc of { a :*: bc ->
 299 --                                                 case bc  of { b :*: c ->
 300 --                                                 D a b c }} },
 301 --                         cd)
 302
 303 mk_sum_stuff i tyvars [datacon]
 304    = ([from_alt], to_body_fn app_exp, rep_var)
 305    where
 306      types        = dataConOrigArgTys datacon
 307      datacon_vars = mkTemplateLocalsNum i types
 308      new_i        = i + length types
 309      app_exp      = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
 310      from_alt     = (DataAlt datacon, datacon_vars, from_alt_rhs)
 311
 312      (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
 313
 314 mk_sum_stuff i tyvars datacons
 315   = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
 316      Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
 317                                  (DataAlt inrDataCon, [r_rep_var], r_to_body)],
 318      rep_var)
 319   where
 320     (l_datacons, r_datacons)            = splitInHalf datacons
 321     (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
 322     (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
 323     rep_tys                             = [idType l_rep_var, idType r_rep_var]
 324     rep_ty                              = mkTyConApp plusTyCon rep_tys
 325     rep_var                             = mkTemplateLocal i rep_ty
 326
 327     wrap :: DataCon -> [Alt Id] -> [Alt Id]
 328         -- Wrap an application of the Inl or Inr constructor round each alternative
 329     wrap datacon alts
 330         = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
 331         where
 332           datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
 333
 334
 335 -- This constructs the c_of datatype from a DataCon and a Type
 336 -- The identity function at the moment.
 337 cOfConstr :: DataCon -> Type -> Type
 338 cOfConstr y z = z
 339
 340
 341 ----------------------------------------------------
 342 --      Dealing with products
 343 ----------------------------------------------------
 344 mk_prod_stuff :: Int                    -- Base for unique names
 345               -> [Id]                   -- arg-ids; args of the original user-defined constructor
 346                                         --      They are bound enclosing from_rhs
 347                                         --      Please bind these in the to_body_fn
 348               -> (Int,                  -- Depleted unique-name supply
 349                   CoreExpr,             -- from-rhs: puts together the representation from the arg_ids
 350                   CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
 351                   Id)                   -- The rep-id; please bind this to the representation
 352
 353 -- For example:
 354 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
 355 --                           \x -> case abc of { a :*: bc ->
 356 --                                 case bc  of { b :*: c  ->
 357 --                                 x,
 358 --                           abc )
 359
 360 -- We need to use different uqiques in the branches
 361 -- because the returned to_body_fns are nested.
 362 -- Hence the returned unqique-name supply
 363
 364 mk_prod_stuff i []              -- Unit case
 365   = (i,
 366      Var (dataConWrapId genUnitDataCon),
 367      \x -> x,
 368      mkTemplateLocal i (mkTyConApp genUnitTyCon []))
 369
 370 mk_prod_stuff i [arg_var]       -- Singleton case
 371   = (i, Var arg_var, \x -> x, arg_var)
 372
 373 mk_prod_stuff i arg_vars        -- Two or more
 374   = (r_i,
 375      mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
 376      \x -> Case (Var rep_var) rep_var
 377                 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
 378      rep_var)
 379   where
 380     (l_arg_vars, r_arg_vars)             = splitInHalf arg_vars
 381     (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
 382     (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i   r_arg_vars
 383     rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
 384     rep_tys = [idType l_rep_var, idType r_rep_var]
 385 \end{code}
 386
 387 A little utility function
 388
 389 \begin{code}
 390 splitInHalf :: [a] -> ([a],[a])
 391 splitInHalf list = (left, right)
 392                  where
 393                    half  = length list `div` 2
 394                    left  = take half list
 395                    right = drop half list
 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.
 407
 408 \begin{code}
 409 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
 410 mkGenericRhs sel_id tyvar tycon
 411   = HsApp (toEP bimap) (HsVar (idName sel_id))
 412   where
 413         -- Initialising the "Environment" with the from/to functions
 414         -- on the datatype (actually tycon) in question
 415         Just (EP from to) = tyConGenInfo tycon  -- Caller checked this will succeed
 416         ep                = EP (HsVar (idName from)) (HsVar (idName to))
 417
 418         -- Takes out the ForAll and the Class rstrictions in front of the
 419         -- type of the method.
 420         (_,_,op_ty) = splitSigmaTy (idType sel_id)
 421
 422         -- Now we probably have a tycon in front
 423         -- of us, quite probably a FunTyCon.
 424         bimap = generate_bimap (tyvar, ep) op_ty
 425
 426 -- EP is the environment of to/from bimaps, but as we only have one type
 427 -- variable at the moment, there is only one EP.
 428
 429 -------------------
 430 generate_bimap ::  (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr
 431 -- Top level case - splitting the TyCon.
 432 generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep
 433                           | otherwise    = bimapApp (tv,ep) (splitTyConApp_maybe ty)
 434
 435 -------------------
 436 bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
 437 bimapApp ep Nothing                 = panic "TcClassDecl: Type Application!"
 438 bimapApp ep (Just (tycon, ty_args))
 439   | tycon == funTyCon       = bimapArrow arg_eps
 440   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
 441   | otherwise               =   -- Otherwise validGenericMethodType will
 442                                 -- have checked that the type is a constant type
 443                               ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) )
 444                               EP idexpr idexpr
 445     where
 446       arg_eps = map (generate_bimap ep) ty_args
 447
 448 -------------------
 449 bimapArrow [ep1, ep2]
 450   = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
 451          toEP   = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
 452   where
 453     from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP   ep1 `HsApp` HsVar g2))
 454     to_body   = toEP   ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
 455
 456 -------------------
 457 bimapTuple eps
 458   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
 459          toEP   = mk_hs_lam [tuple_pat] to_body }
 460   where
 461     names       = take (length eps) genericNames
 462     tuple_pat   = TuplePatIn (map VarPatIn names) Boxed
 463     eps_w_names = eps `zip` names
 464     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 465     from_body   = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 466
 467 -------------------
 468 genericNames :: [Name]
 469 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
 470 (g1:g2:g3:_) = genericNames
 471
 472 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
 473 idexpr              = mk_hs_lam [VarPatIn g3] (HsVar g3)
 474 \end{code}