compiler/types/Generics.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   7 -- The above warning supression flag is a temporary kludge.
   8 -- While working on this module you are encouraged to remove it and fix
   9 -- any warnings in the module. See
  10 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  11 -- for details
  12
  13 module Generics ( canDoGenerics, mkTyConGenericBinds,
  14                   mkGenericRhs,
  15                   validGenericInstanceType, validGenericMethodType,
  16                   mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
  17                   MetaTyCons(..), metaTyCons2TyCons
  18     ) where
  19
  20
  21 import HsSyn
  22 import Type
  23 import TcType
  24 import DataCon
  25
  26 import TyCon
  27 import Name hiding (varName)
  28 import Module (moduleName, moduleNameString)
  29 import RdrName
  30 import BasicTypes
  31 import Var hiding (varName)
  32 import VarSet
  33 import Id
  34 import TysWiredIn
  35 import PrelNames
  36 -- For generation of representation types
  37 import TcEnv (tcLookupTyCon)
  38 import TcRnMonad (TcM, newUnique)
  39 import HscTypes
  40
  41 import SrcLoc
  42 import Util
  43 import Bag
  44 import Outputable
  45 import FastString
  46
  47 #include "HsVersions.h"
  48 \end{code}
  49
  50 Roadmap of what's where in the Generics work.
  51 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  52
  53 Parser
  54 No real checks.
  55
  56 RnSource.rnHsType
  57   Checks that HsNumTy has a "1" in it.
  58
  59 TcInstDcls.mkGenericInstance:
  60   Checks for invalid type patterns, such as f {| Int |}
  61
  62 TcClassDcl.tcClassSig
  63   Checks for a method type that is too complicated;
  64         e.g. has for-alls or lists in it
  65   We could lift this restriction
  66
  67 TcClassDecl.mkDefMethRhs
  68   Checks that the instance type is simple, in an instance decl
  69   where we let the compiler fill in a generic method.
  70         e.g.  instance C (T Int)
  71         is not valid if C has generic methods.
  72
  73 TcClassDecl.checkGenericClassIsUnary
  74   Checks that we don't have generic methods in a multi-parameter class
  75
  76 TcClassDecl.checkDefaultBinds
  77   Checks that all the equations for a method in a class decl
  78   are generic, or all are non-generic
  79
  80
  81
  82 Checking that the type constructors which are present in Generic
  83 patterns (not Unit, this is done differently) is done in mk_inst_info
  84 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
  85 HsOpTy is tied to Generic definitions which is not a very good design
  86 feature, indeed a bug. However, the check is easy to move from
  87 tcHsType back to mk_inst_info and everything will be fine. Also see
  88 bug #5. [I don't think that this is the case anymore after SPJ's latest
  89 changes in that regard.  Delete this comment?  -=chak/7Jun2]
  90
  91 Generics.lhs
  92
  93 Making generic information to put into a tycon. Constructs the
  94 representation type, which, I think, are not used later. Perhaps it is
  95 worth removing them from the GI datatype. Although it does get used in
  96 the construction of conversion functions (internally).
  97
  98 TyCon.lhs
  99
 100 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
 101
 102 TysWiredIn.lhs
 103
 104 Defines generic and other type and data constructors.
 105
 106 This is sadly incomplete, but will be added to.
 107
 108
 109 Bugs & shortcomings of existing implementation:
 110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 111
 112 2. Another pretty big bug I dscovered at the last minute when I was
 113 testing the code is that at the moment the type variable of the class
 114 is scoped over the entire declaration, including the patterns. For
 115 instance, if I have the following code,
 116
 117 class Er a where
 118  ...
 119   er {| Plus a b |} (Inl x) (Inl y) = er x y
 120   er {| Plus a b |} (Inr x) (Inr y) = er x y
 121   er {| Plus a b |} _ _ = False
 122
 123 and I print out the types of the generic patterns, I get the
 124 following.  Note that all the variable names for "a" are the same,
 125 while for "b" they are all different.
 126
 127 check_ty
 128     [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
 129      std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
 130      std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
 131
 132 This is a bug as if I change the code to
 133
 134  er {| Plus c b |} (Inl x)  (Inl y) = er x y
 135
 136 all the names come out to be different.
 137
 138 Thus, all the types (Plus a b) come out to be different, so I cannot
 139 compare them and test whether they are all the same and thus cannot
 140 return an error if the type variables are different.
 141
 142 Temporary fix/hack. I am not checking for this, I just assume they are
 143 the same, see line "check_ty = True" in TcInstDecls. When we resolve
 144 the issue with variables, though - I assume that we will make them to
 145 be the same in all the type patterns, jus uncomment the check and
 146 everything should work smoothly.
 147
 148 Hence, I have also left the rather silly construction of:
 149 * extracting all the type variables from all the types
 150 * putting them *all* into the environment
 151 * typechecking all the types
 152 * selecting one of them and using it as the instance_ty.
 153
 154 (the alternative is to make sure that all the types are the same,
 155 taking one, extracting its variables, putting them into the environment,
 156 type checking it, using it as the instance_ty)
 157
 158 6. What happens if we do not supply all of the generic patterns? At
 159 the moment, the compiler crashes with an error message "Non-exhaustive
 160 patterns in a generic declaration"
 161
 162
 163 What has not been addressed:
 164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 165
 166 Contexts. In the generated instance declarations for the 3 primitive
 167 type constructors, we need contexts. It is unclear what those should
 168 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
 169
 170 Type application. We have type application in expressions
 171 (essentially) on the lhs of an equation. Do we want to allow it on the
 172 RHS?
 173
 174 Scoping of type variables in a generic definition. At the moment, (see
 175 TcInstDecls) we extract the type variables inside the type patterns
 176 and add them to the environment. See my bug #2 above. This seems pretty
 177 important.
 178
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Getting the representation type out}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 validGenericInstanceType :: Type -> Bool
 189   -- Checks for validity of the type pattern in a generic
 190   -- declaration.  It's ok to have
 191   --    f {| a + b |} ...
 192   -- but it's not OK to have
 193   --    f {| a + Int |}
 194
 195 validGenericInstanceType inst_ty
 196   = case tcSplitTyConApp_maybe inst_ty of
 197         Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
 198         Nothing           ->  False
 199
 200 validGenericMethodType :: Type -> Bool
 201   -- At the moment we only allow method types built from
 202   --    * type variables
 203   --    * function arrow
 204   --    * boxed tuples
 205   --    * lists
 206   --    * an arbitrary type not involving the class type variables
 207   --            e.g. this is ok:        forall b. Ord b => [b] -> a
 208   --                 where a is the class variable
 209 validGenericMethodType ty
 210   = valid tau
 211   where
 212     (local_tvs, _, tau) = tcSplitSigmaTy ty
 213
 214     valid ty
 215       | not (isTauTy ty) = False        -- Note [Higher ramk methods]
 216       | isTyVarTy ty     = True
 217       | no_tyvars_in_ty  = True
 218       | otherwise        = case tcSplitTyConApp_maybe ty of
 219                                 Just (tc,tys) -> valid_tycon tc && all valid tys
 220                                 Nothing       -> False
 221       where
 222         no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 223
 224     valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
 225         -- Compare bimapApp, below
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection{Generating representation types}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 \begin{code}
 236 canDoGenerics :: ThetaType -> [DataCon] -> Bool
 237 -- Called on source-code data types, to see if we should generate
 238 -- generic functions for them.  (This info is recorded in the interface file for
 239 -- imported data types.)
 240
 241 canDoGenerics stupid_theta data_cons
 242   =  not (any bad_con data_cons)        -- See comment below
 243
 244   -- && not (null data_cons)            -- No values of the type
 245   -- JPM: we now support empty datatypes
 246
 247      && null stupid_theta -- We do not support datatypes with context (for now)
 248   where
 249     bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
 250         -- If any of the constructor has an unboxed type as argument,
 251         -- then we can't build the embedding-projection pair, because
 252         -- it relies on instantiating *polymorphic* sum and product types
 253         -- at the argument types of the constructors
 254
 255         -- Nor can we do the job if it's an existential data constructor,
 256
 257         -- Nor if the args are polymorphic types (I don't think)
 258     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
 259   -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it
 260         -- like this for now...
 261 \end{code}
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection{Generating the RHS of a generic default method}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 \begin{code}
 270 type US = Int   -- Local unique supply, just a plain Int
 271 type Alt = (LPat RdrName, LHsExpr RdrName)
 272 {-
 273 data GenRep = GenRep {
 274     genBindsFrom0 :: TyCon -> LHsBinds RdrName
 275   , genBindsTo0 :: TyCon -> LHsBinds RdrName
 276   , genBindsFrom1 :: TyCon -> LHsBinds RdrName
 277   , genBindsTo1 :: TyCon -> LHsBinds RdrName
 278   , genBindsModuleName :: TyCon -> LHsBinds RdrName
 279   , genBindsConName :: DataCon -> LHsBinds RdrName
 280   , genBindsConFixity :: DataCon -> LHsBinds RdrName
 281   , genBindsConIsRecord :: DataCon -> LHsBinds RdrName
 282   , genBindsSelName :: DataCon -> Int -> LHsBinds RdrName
 283   }
 284 -}
 285 -- Bindings for the Representable0 instance
 286 mkBindsRep0 :: TyCon -> LHsBinds RdrName
 287 mkBindsRep0 tycon =
 288     unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
 289   `unionBags`
 290     unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
 291       where
 292         from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
 293         to0_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts  ]
 294         loc           = srcLocSpan (getSrcLoc tycon)
 295         datacons      = tyConDataCons tycon
 296
 297         -- Recurse over the sum first
 298         from0_alts, to0_alts :: [Alt]
 299         (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
 300
 301 -- Disabled
 302 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
 303 mkTyConGenericBinds _tycon =
 304   {-
 305     unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
 306   `unionBags`
 307     unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
 308   `unionBags`
 309     mkMeta loc tycon
 310   -}
 311     emptyBag
 312 {-
 313   where
 314     from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
 315     to0_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts  ]
 316     loc           = srcLocSpan (getSrcLoc tycon)
 317     datacons      = tyConDataCons tycon
 318     (from0_RDR, to0_RDR) = mkGenericNames tycon
 319
 320     -- Recurse over the sum first
 321     from0_alts, to0_alts :: [Alt]
 322     (from0_alts, to0_alts) = mkSum init_us tycon datacons
 323     init_us = 1 :: US -- Unique supply
 324 -}
 325
 326 --------------------------------------------------------------------------------
 327 -- Type representation
 328 --------------------------------------------------------------------------------
 329 {-
 330 mkRep0Ty :: TyCon -> LHsType Name
 331 mkRep0Ty tycon = res
 332   where
 333     res = d1 `nlHsAppTy` (cons datacons)
 334     d1 = nlHsTyVar d1TyConName `nlHsAppTy` nlHsTyVar d1TyConName -- TODO
 335     c1 = nlHsTyVar c1TyConName `nlHsAppTy` nlHsTyVar c1TyConName -- TODO
 336     s1 = nlHsTyVar s1TyConName `nlHsAppTy` nlHsTyVar noSelTyConName -- TODO
 337     plus a b = nlHsTyVar sumTyConName `nlHsAppTy` a `nlHsAppTy` b
 338     times a b = nlHsTyVar prodTyConName `nlHsAppTy` a `nlHsAppTy` b
 339     k1 x = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar x
 340
 341     datacons = tyConDataCons tycon
 342     n_args datacon = dataConSourceArity datacon
 343     datacon_vars datacon = map mkGenericLocal [1 .. n_args datacon]
 344
 345     cons ds = c1 `nlHsAppTy` sum ds
 346     sum [] = nlHsTyVar v1TyConName
 347     sum l  = foldBal plus (map sel l)
 348     sel d = s1 `nlHsAppTy` prod (dataConOrigArgTys d)
 349     prod [] = nlHsTyVar u1TyConName
 350     prod l  = foldBal times (map arg l)
 351     arg :: Type -> LHsType Name
 352     -- TODO
 353     arg t = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar v1TyConName -- TODO
 354 -}
 355
 356 tc_mkRep0Ty :: -- The type to generate representation for
 357                TyCon
 358                -- Metadata datatypes to refer to
 359             -> MetaTyCons
 360                -- Generated representation0 type
 361             -> TcM Type
 362 tc_mkRep0Ty tycon metaDts =
 363   do
 364     d1 <- tcLookupTyCon d1TyConName
 365     c1 <- tcLookupTyCon c1TyConName
 366     s1 <- tcLookupTyCon s1TyConName
 367     rec0 <- tcLookupTyCon rec0TyConName
 368     u1 <- tcLookupTyCon u1TyConName
 369     v1 <- tcLookupTyCon v1TyConName
 370     plus <- tcLookupTyCon sumTyConName
 371     times <- tcLookupTyCon prodTyConName
 372
 373     let mkSum  a b = mkTyConApp plus  [a,b]
 374         mkProd a b = mkTyConApp times [a,b]
 375         mkRec0 a   = mkTyConApp rec0  [a]
 376         mkD    a   = mkTyConApp d1    [metaDTyCon, sum (tyConDataCons a)]
 377         mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a)]
 378         mkS    d a = mkTyConApp s1    [d, a]
 379
 380         sum [] = mkTyConTy v1
 381         sum l  = ASSERT (length metaCTyCons == length l)
 382                    foldBal mkSum [ mkC i d a
 383                                  | (d,(a,i)) <- zip metaCTyCons (zip l [0..]) ]
 384         prod :: Int -> [Type] -> Type
 385         prod i [] = ASSERT (length metaSTyCons > i)
 386                       ASSERT (length (metaSTyCons !! i) == 0)
 387                         mkTyConTy u1
 388         prod i l  = ASSERT (length metaSTyCons > i)
 389                       ASSERT (length l == length (metaSTyCons !! i))
 390                         foldBal mkProd [ arg d a
 391                                        | (d,a) <- zip (metaSTyCons !! i) l ]
 392
 393         arg d t = mkS d (mkRec0 t)
 394
 395         metaDTyCon  = mkTyConTy (metaD metaDts)
 396         metaCTyCons = map mkTyConTy (metaC metaDts)
 397         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
 398
 399     return (mkD tycon)
 400
 401 tc_mkRep0TyCon :: TyCon           -- The type to generate representation for
 402                -> MetaTyCons      -- Metadata datatypes to refer to
 403                -> TcM TyCon       -- Generated representation0 type
 404 tc_mkRep0TyCon tycon metaDts =
 405 -- Consider the example input tycon `D`, where data D a b = D_ a
 406   do
 407     uniq1   <- newUnique
 408     uniq2   <- newUnique
 409     -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
 410     rep0Ty  <- tc_mkRep0Ty tycon metaDts
 411     -- `rep0` = GHC.Generics.Rep0 (type family)
 412     rep0    <- tcLookupTyCon rep0TyConName
 413
 414     let mod     = nameModule  (tyConName tycon)
 415         loc     = nameSrcSpan (tyConName tycon)
 416         -- `repName` is a name we generate for the synonym
 417         repName = mkExternalName uniq1 mod (mkGenR0 (nameOccName (tyConName tycon))) loc
 418         -- `coName` is a name for the coercion
 419         coName  = mkExternalName uniq2 mod (mkGenR0 (nameOccName (tyConName tycon))) loc
 420         -- `tyvars` = [a,b]
 421         tyvars  = tyConTyVars tycon
 422         -- `appT` = D a b
 423         appT    = [mkTyConApp tycon (mkTyVarTys tyvars)]
 424         -- Result
 425         res = mkSynTyCon repName
 426                  -- rep0Ty has kind `kind of D` -> *
 427                  (tyConKind tycon `mkArrowKind` liftedTypeKind)
 428                  tyvars (SynonymTyCon rep0Ty)
 429                  (FamInstTyCon rep0 appT
 430                    (mkCoercionTyCon coName (tyConArity tycon)
 431                      -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
 432                      (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
 433
 434     return res
 435
 436 --------------------------------------------------------------------------------
 437 -- Meta-information
 438 --------------------------------------------------------------------------------
 439
 440 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
 441                                metaD :: TyCon
 442                                -- One meta datatype per constructor
 443                              , metaC :: [TyCon]
 444                                -- One meta datatype per selector per constructor
 445                              , metaS :: [[TyCon]] }
 446
 447 instance Outputable MetaTyCons where
 448   ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
 449
 450 metaTyCons2TyCons :: MetaTyCons -> [TyCon]
 451 metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
 452
 453
 454 -- Bindings for Datatype, Constructor, and Selector instances
 455 mkBindsMetaD :: FixityEnv -> TyCon
 456              -> ( LHsBinds RdrName      -- Datatype instance
 457                 , [LHsBinds RdrName]    -- Constructor instances
 458                 , [[LHsBinds RdrName]]) -- Selector instances
 459 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
 460       where
 461         mkBag l = foldr1 unionBags
 462                     [ unitBag (L loc (mkFunBind (L loc name) matches))
 463                         | (name, matches) <- l ]
 464         dtBinds       = mkBag [ (datatypeName_RDR, dtName_matches)
 465                               , (moduleName_RDR, moduleName_matches)]
 466
 467         allConBinds   = map conBinds datacons
 468         conBinds c    = mkBag ( [ (conName_RDR, conName_matches c)]
 469                               ++ ifElseEmpty (dataConIsInfix c)
 470                                    [ (conFixity_RDR, conFixity_matches c) ]
 471                               ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
 472                                    [ (conIsRecord_RDR, conIsRecord_matches c) ]
 473                               ++ ifElseEmpty (isTupleCon c)
 474                                    [(conIsTuple_RDR
 475                                     ,conIsTuple_matches (dataConTyCon c))]
 476                               )
 477
 478         ifElseEmpty p x = if p then x else []
 479         fixity c      = case lookupFixity fix_env (dataConName c) of
 480                           Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
 481                           Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
 482                           Fixity n InfixN -> buildFix n notAssocDataCon_RDR
 483         buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
 484                                                      , nlHsIntLit (toInteger n)]
 485
 486         allSelBinds   = map (map selBinds) datasels
 487         selBinds s    = mkBag [(selName_RDR, selName_matches s)]
 488
 489         loc           = srcLocSpan (getSrcLoc tycon)
 490         mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
 491         datacons      = tyConDataCons tycon
 492         datasels      = map dataConFieldLabels datacons
 493
 494         dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName
 495                            $ tycon
 496         moduleName_matches = mkStringLHS . moduleNameString . moduleName
 497                            . nameModule . tyConName $ tycon
 498
 499         conName_matches     c = mkStringLHS . showPpr . nameOccName
 500                               . dataConName $ c
 501         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
 502         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
 503         -- TODO: check that this works
 504         conIsTuple_matches  c = [mkSimpleHsAlt nlWildPat
 505                                   (nlHsApp (nlHsVar arityDataCon_RDR)
 506                                            (nlHsIntLit
 507                                              (toInteger (tupleTyConArity c))))]
 508
 509         selName_matches     s = mkStringLHS (showPpr (nameOccName s))
 510
 511
 512 --------------------------------------------------------------------------------
 513 -- Dealing with sums
 514 --------------------------------------------------------------------------------
 515
 516 mkSum :: US          -- Base for generating unique names
 517       -> TyCon       -- The type constructor
 518       -> [DataCon]   -- The data constructors
 519       -> ([Alt],     -- Alternatives for the T->Trep "from" function
 520           [Alt])     -- Alternatives for the Trep->T "to" function
 521
 522 -- Datatype without any constructors
 523 mkSum _us tycon [] = ([from_alt], [to_alt])
 524   where
 525     from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
 526     to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
 527                -- These M1s are meta-information for the datatype
 528     makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
 529     errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
 530     errMsgTo = "No values for empty datatype " ++ showPpr tycon
 531
 532 -- Datatype with at least one constructor
 533 mkSum us _tycon datacons =
 534   unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
 535
 536 -- Build the sum for a particular constructor
 537 mk1Sum :: US        -- Base for generating unique names
 538        -> Int       -- The index of this constructor
 539        -> Int       -- Total number of constructors
 540        -> DataCon   -- The data constructor
 541        -> (Alt,     -- Alternative for the T->Trep "from" function
 542            Alt)     -- Alternative for the Trep->T "to" function
 543 mk1Sum us i n datacon = (from_alt, to_alt)
 544   where
 545     n_args = dataConSourceArity datacon -- Existentials already excluded
 546
 547     datacon_vars = map mkGenericLocal [us .. us+n_args-1]
 548     us'          = us + n_args
 549
 550     datacon_rdr  = getRdrName datacon
 551     app_exp      = nlHsVarApps datacon_rdr datacon_vars
 552
 553     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
 554     from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
 555
 556     to_alt     = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
 557                  -- These M1s are meta-information for the datatype
 558     to_alt_rhs = app_exp
 559
 560 -- Generates the L1/R1 sum pattern
 561 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
 562 genLR_P i n p
 563   | n == 0       = error "impossible"
 564   | n == 1       = p
 565   | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
 566   | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
 567                      where m = div n 2
 568
 569 -- Generates the L1/R1 sum expression
 570 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
 571 genLR_E i n e
 572   | n == 0       = error "impossible"
 573   | n == 1       = e
 574   | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
 575   | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
 576                      where m = div n 2
 577
 578 --------------------------------------------------------------------------------
 579 -- Dealing with products
 580 --------------------------------------------------------------------------------
 581
 582 -- Build a product expression
 583 mkProd_E :: US                          -- Base for unique names
 584                -> [RdrName]       -- List of variables matched on the lhs
 585                -> LHsExpr RdrName -- Resulting product expression
 586 mkProd_E _ []   = mkM1_E (nlHsVar u1DataCon_RDR)
 587 mkProd_E _ vars = mkM1_E (foldBal prod appVars)
 588                    -- These M1s are meta-information for the constructor
 589   where
 590     appVars = map wrapArg_E vars
 591     prod a b = prodDataCon_RDR `nlHsApps` [a,b]
 592
 593 -- TODO: Produce a P0 when v is a parameter
 594 wrapArg_E :: RdrName -> LHsExpr RdrName
 595 wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
 596               -- This M1 is meta-information for the selector
 597
 598 -- Build a product pattern
 599 mkProd_P :: US                        -- Base for unique names
 600                -> [RdrName]     -- List of variables to match
 601                -> LPat RdrName  -- Resulting product pattern
 602 mkProd_P _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
 603 mkProd_P _ vars = mkM1_P (foldBal prod appVars)
 604                    -- These M1s are meta-information for the constructor
 605   where
 606     appVars = map wrapArg_P vars
 607     prod a b = prodDataCon_RDR `nlConPat` [a,b]
 608
 609 -- TODO: Produce a P0 when v is a parameter
 610 wrapArg_P :: RdrName -> LPat RdrName
 611 wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
 612               -- This M1 is meta-information for the selector
 613
 614
 615 mkGenericLocal :: US -> RdrName
 616 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 617
 618 mkGenericNames :: TyCon -> (RdrName, RdrName)
 619 mkGenericNames tycon
 620   = (from_RDR, to_RDR)
 621   where
 622     tc_name  = tyConName tycon
 623     tc_occ   = nameOccName tc_name
 624     tc_mod   = ASSERT( isExternalName tc_name ) nameModule tc_name
 625     from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
 626     to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
 627
 628 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
 629 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 630
 631 mkM1_P :: LPat RdrName -> LPat RdrName
 632 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
 633
 634 -- | Variant of foldr1 for producing balanced lists
 635 foldBal :: (a -> a -> a) -> [a] -> a
 636 foldBal op = foldBal' op (error "foldBal: empty list")
 637
 638 foldBal' :: (a -> a -> a) -> a -> [a] -> a
 639 foldBal' _  x []  = x
 640 foldBal' _  _ [y] = y
 641 foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
 642                     in foldBal' op x a `op` foldBal' op x b
 643
 644 \end{code}
 645
 646 %************************************************************************
 647 %*                                                                      *
 648 \subsection{Generating the RHS of a generic default method}
 649 %*                                                                      *
 650 %************************************************************************
 651
 652 Generating the Generic default method.  Uses the bimaps to generate the
 653 actual method. All of this is rather incomplete, but it would be nice
 654 to make even this work.  Example
 655
 656         class Foo a where
 657           op :: Op a
 658
 659         instance Foo T
 660
 661 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
 662
 663         instance Foo T where
 664            op = <mkGenericRhs op a T>
 665
 666 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
 667
 668         toOp   :: Op Trep -> Op T
 669         fromOp :: Op T    -> Op Trep
 670
 671 (the bimap) and then fill in the RHS with
 672
 673         instance Foo T where
 674            op = toOp op
 675
 676 Remember, we're generating a RenamedHsExpr, so the result of all this
 677 will be fed to the type checker.  So the 'op' on the RHS will be
 678 at the representation type for T, Trep.
 679
 680
 681 Note [Polymorphic methods]
 682 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 683 Suppose the class op is polymorphic:
 684
 685         class Baz a where
 686           op :: forall b. Ord b => a -> b -> b
 687
 688 Then we can still generate a bimap with
 689
 690         toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
 691
 692 and fill in the instance decl thus
 693
 694         instance Foo T where
 695            op = toOp op
 696
 697 By the time the type checker has done its stuff we'll get
 698
 699         instance Foo T where
 700            op = \b. \dict::Ord b. toOp b (op Trep b dict)
 701
 702 Note [Higher rank methods]
 703 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 704 Higher-rank method types don't work, because we'd generate a bimap that
 705 needs impredicative polymorphism.  In principle that should be possible
 706 (with boxy types and all) but it would take a bit of working out.   Here's
 707 an example:
 708   class ChurchEncode k where
 709     match :: k -> z
 710           -> (forall a b z. a -> b -> z)  {- product -}
 711           -> (forall a   z. a -> z)       {- left -}
 712           -> (forall a   z. a -> z)       {- right -}
 713           -> z
 714
 715     match {| Unit    |} Unit      unit prod left right = unit
 716     match {| a :*: b |} (x :*: y) unit prod left right = prod x y
 717     match {| a :+: b |} (Inl l)   unit prod left right = left l
 718     match {| a :+: b |} (Inr r)   unit prod left right = right r
 719
 720 \begin{code}
 721 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
 722 mkGenericRhs sel_id tyvar tycon
 723   = ASSERT( isSingleton ctxt )  -- Checks shape of selector-id context
 724 --    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
 725     mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
 726   where
 727         -- Initialising the "Environment" with the from/to functions
 728         -- on the datatype (actually tycon) in question
 729         (from_RDR, to_RDR) = mkGenericNames tycon
 730
 731         -- Instantiate the selector type, and strip off its class context
 732         (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
 733
 734         -- Do it again!  This deals with the case where the method type
 735         -- is polymorphic -- see Note [Polymorphic methods] above
 736         (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 737
 738         -- Now we probably have a tycon in front
 739         -- of us, quite probably a FunTyCon.
 740         ep    = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
 741         bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
 742
 743 type EPEnv = (TyVar,                    -- The class type variable
 744               EP (LHsExpr RdrName),     -- The EP it maps to
 745               [TyVar]                   -- Other in-scope tyvars; they have an identity EP
 746              )
 747
 748 -------------------
 749 generate_bimap :: EPEnv
 750                -> Type
 751                -> EP (LHsExpr RdrName)
 752 -- Top level case - splitting the TyCon.
 753 generate_bimap env@(tv,ep,local_tvs) ty
 754   | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 755   = idEP        -- A constant type
 756
 757   | Just tv1 <- getTyVar_maybe ty
 758   = ASSERT( tv == tv1 ) ep                                      -- The class tyvar
 759
 760   | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
 761   = bimapTyCon tycon (map (generate_bimap env) ty_args)
 762
 763   | otherwise
 764   = pprPanic "generate_bimap" (ppr ty)
 765
 766 -------------------
 767 bimapTyCon :: TyCon -> [EP  (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 768 bimapTyCon tycon arg_eps
 769   | tycon == funTyCon       = bimapArrow arg_eps
 770   | tycon == listTyCon      = bimapList arg_eps
 771   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
 772   | otherwise               = pprPanic "bimapTyCon" (ppr tycon)
 773
 774 -------------------
 775 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
 776 bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 777 bimapArrow [ep1, ep2]
 778   = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
 779          toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
 780   where
 781     from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP   ep1 `mkHsApp` nlHsVar b_RDR))
 782     to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
 783
 784 -------------------
 785 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
 786 bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 787 bimapTuple eps
 788   = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
 789          toEP   = mkHsLam [noLoc tuple_pat] to_body }
 790   where
 791     names       = takeList eps gs_RDR
 792     tuple_pat   = TuplePat (map nlVarPat names) Boxed placeHolderType
 793     eps_w_names = eps `zip` names
 794     to_body     = mkLHsTupleExpr [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
 795     from_body   = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
 796
 797 -------------------
 798 -- bimapList :: EP a b -> EP [a] [b]
 799 bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
 800 bimapList [ep]
 801   = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
 802          toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
 803
 804 -------------------
 805 a_RDR, b_RDR :: RdrName
 806 a_RDR   = mkVarUnqual (fsLit "a")
 807 b_RDR   = mkVarUnqual (fsLit "b")
 808
 809 gs_RDR :: [RdrName]
 810 gs_RDR  = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
 811
 812 idEP :: EP (LHsExpr RdrName)
 813 idEP = EP idexpr idexpr
 814      where
 815        idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
 816 \end{code}