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