% % (c) The University of Glasgow 2006 % \begin{code}

    {-# OPTIONS -fno-warn-incomplete-patterns #-}
    -- The above warning supression flag is a temporary kludge.
    -- While working on this module you are encouraged to remove it and fix
    -- any warnings in the module. See
    --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
    -- for details

    module Generics ( canDoGenerics, mkTyConGenericBinds,
    		  mkGenericRhs,
    		  validGenericInstanceType, validGenericMethodType
        ) where

    import HsSyn
    import Type
    import TcType
    import DataCon

    import TyCon
    import Name
    import RdrName
    import BasicTypes
    import Var
    import VarSet
    import Id
    import TysWiredIn
    import PrelNames

    import SrcLoc
    import Util
    import Bag
    import Outputable
    import FastString

    #include "HsVersions.h"

\end{code} Roadmap of what's where in the Generics work. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Parser No real checks. RnSource.rnHsType Checks that HsNumTy has a "1" in it. TcInstDcls.mkGenericInstance: Checks for invalid type patterns, such as f {| Int |} TcClassDcl.tcClassSig Checks for a method type that is too complicated; e.g. has for-alls or lists in it We could lift this restriction TcClassDecl.mkDefMethRhs Checks that the instance type is simple, in an instance decl where we let the compiler fill in a generic method. e.g. instance C (T Int) is not valid if C has generic methods. TcClassDecl.checkGenericClassIsUnary Checks that we don't have generic methods in a multi-parameter class TcClassDecl.checkDefaultBinds Checks that all the equations for a method in a class decl are generic, or all are non-generic Checking that the type constructors which are present in Generic patterns (not Unit, this is done differently) is done in mk_inst_info (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that HsOpTy is tied to Generic definitions which is not a very good design feature, indeed a bug. However, the check is easy to move from tcHsType back to mk_inst_info and everything will be fine. Also see bug #5. [I don't think that this is the case anymore after SPJ's latest changes in that regard. Delete this comment? -=chak/7Jun2] Generics.lhs Making generic information to put into a tycon. Constructs the representation type, which, I think, are not used later. Perhaps it is worth removing them from the GI datatype. Although it does get used in the construction of conversion functions (internally). TyCon.lhs Just stores generic information, accessible by tyConGenInfo or tyConGenIds. TysWiredIn.lhs Defines generic and other type and data constructors. This is sadly incomplete, but will be added to. Bugs & shortcomings of existing implementation: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2. Another pretty big bug I dscovered at the last minute when I was testing the code is that at the moment the type variable of the class is scoped over the entire declaration, including the patterns. For instance, if I have the following code, class Er a where ... er {| Plus a b |} (Inl x) (Inl y) = er x y er {| Plus a b |} (Inr x) (Inr y) = er x y er {| Plus a b |} _ _ = False and I print out the types of the generic patterns, I get the following. Note that all the variable names for "a" are the same, while for "b" they are all different. check_ty [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-}, std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-}, std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}] This is a bug as if I change the code to er {| Plus c b |} (Inl x) (Inl y) = er x y all the names come out to be different. Thus, all the types (Plus a b) come out to be different, so I cannot compare them and test whether they are all the same and thus cannot return an error if the type variables are different. Temporary fix/hack. I am not checking for this, I just assume they are the same, see line "check_ty = True" in TcInstDecls. When we resolve the issue with variables, though - I assume that we will make them to be the same in all the type patterns, jus uncomment the check and everything should work smoothly. Hence, I have also left the rather silly construction of: * extracting all the type variables from all the types * putting them *all* into the environment * typechecking all the types * selecting one of them and using it as the instance_ty. (the alternative is to make sure that all the types are the same, taking one, extracting its variables, putting them into the environment, type checking it, using it as the instance_ty) 6. What happens if we do not supply all of the generic patterns? At the moment, the compiler crashes with an error message "Non-exhaustive patterns in a generic declaration" What has not been addressed: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Contexts. In the generated instance declarations for the 3 primitive type constructors, we need contexts. It is unclear what those should be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b) Type application. We have type application in expressions (essentially) on the lhs of an equation. Do we want to allow it on the RHS? Scoping of type variables in a generic definition. At the moment, (see TcInstDecls) we extract the type variables inside the type patterns and add them to the environment. See my bug #2 above. This seems pretty important. %************************************************************************ %* * \subsection{Getting the representation type out} %* * %************************************************************************ \begin{code}

    validGenericInstanceType :: Type -> Bool
      -- Checks for validity of the type pattern in a generic
      -- declaration.  It's ok to have
      --	f {| a + b |} ...
      -- but it's not OK to have
      --	f {| a + Int |}

    validGenericInstanceType inst_ty
      = case tcSplitTyConApp_maybe inst_ty of
    	Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
    	Nothing		  ->  False

    validGenericMethodType :: Type -> Bool
      -- At the moment we only allow method types built from
      -- 	* type variables
      --	* function arrow
      --	* boxed tuples
      --    * lists
      --	* an arbitrary type not involving the class type variables
      --		e.g. this is ok: 	forall b. Ord b => [b] -> a
      --	             where a is the class variable
    validGenericMethodType ty
      = valid tau
      where
        (local_tvs, _, tau) = tcSplitSigmaTy ty

        valid ty
          | not (isTauTy ty) = False 	-- Note [Higher ramk methods]
          | isTyVarTy ty     = True
          | no_tyvars_in_ty	 = True
          | otherwise	 = case tcSplitTyConApp_maybe ty of
    				Just (tc,tys) -> valid_tycon tc && all valid tys
    				Nothing	      -> False
          where
    	no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))

        valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
    	-- Compare bimapApp, below

\end{code} %************************************************************************ %* * \subsection{Generating representation types} %* * %************************************************************************ \begin{code}

    canDoGenerics :: [DataCon] -> Bool
    -- Called on source-code data types, to see if we should generate
    -- generic functions for them.  (This info is recorded in the interface file for
    -- imported data types.)

    canDoGenerics data_cons
      =  not (any bad_con data_cons) 	-- See comment below
      && not (null data_cons)		-- No values of the type
      where
        bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
      	-- If any of the constructor has an unboxed type as argument,
    	-- then we can't build the embedding-projection pair, because
    	-- it relies on instantiating *polymorphic* sum and product types
    	-- at the argument types of the constructors

    	-- Nor can we do the job if it's an existential data constructor,

    	-- Nor if the args are polymorphic types (I don't think)
        bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)

\end{code} %************************************************************************ %* * \subsection{Generating the RHS of a generic default method} %* * %************************************************************************ \begin{code}

    type US = Int	-- Local unique supply, just a plain Int
    type FromAlt = (LPat RdrName, LHsExpr RdrName)

    mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
    mkTyConGenericBinds tycon
      = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
    	`unionBags`
        unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
      where
        from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
        to_matches   = [mkSimpleHsAlt to_pat to_body]
        loc	     = srcLocSpan (getSrcLoc tycon)
        datacons = tyConDataCons tycon
        (from_RDR, to_RDR) = mkGenericNames tycon

        -- Recurse over the sum first
        from_alts :: [FromAlt]
        (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
        init_us = 1::Int		-- Unique supply

    ----------------------------------------------------
    --	Dealing with sums
    ----------------------------------------------------

    mk_sum_stuff :: US 			-- Base for generating unique names
    	     -> [DataCon]	 	-- The data constructors
    	     -> ([FromAlt],				-- Alternatives for the T->Trep "from" function
    		 InPat RdrName, LHsExpr RdrName)	-- Arg and body of the Trep->T "to" function

    -- For example, given
    --	data T = C | D Int Int Int
    --
    -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
    --			   case cd of { Inl u -> C;
    --  					Inr abc -> case abc of { a :*: bc ->
    --						   case bc  of { b :*: c ->
    --						   D a b c }} },
    --			   cd)

    mk_sum_stuff us [datacon]
       = ([from_alt], to_pat, to_body_fn app_exp)
       where
         n_args = dataConSourceArity datacon	-- Existentials already excluded

         datacon_vars = map mkGenericLocal [us .. us+n_args-1]
         us'          = us + n_args

         datacon_rdr  = getRdrName datacon
         app_exp      = nlHsVarApps datacon_rdr datacon_vars
         from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)

         (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars

    mk_sum_stuff us datacons
      = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
         nlVarPat to_arg,
         noLoc (HsCase (nlHsVar to_arg)
    	    (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
    			   mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
      where
        (l_datacons, r_datacons)		= splitInHalf datacons
        (l_from_alts, l_to_pat, l_to_body)	= mk_sum_stuff us' l_datacons
        (r_from_alts, r_to_pat, r_to_body)	= mk_sum_stuff us' r_datacons

        to_arg = mkGenericLocal us
        us'	   = us+1

        wrap :: RdrName -> [FromAlt] -> [FromAlt]
    	-- Wrap an application of the Inl or Inr constructor round each alternative
        wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]

    ----------------------------------------------------
    --	Dealing with products
    ----------------------------------------------------
    mk_prod_stuff :: US			-- Base for unique names
    	      -> [RdrName]		-- arg-ids; args of the original user-defined constructor
    					-- 	They are bound enclosing from_rhs
    					-- 	Please bind these in the to_body_fn
    	      -> (US,			-- Depleted unique-name supply
    		  LHsExpr RdrName, 			-- from-rhs: puts together the representation from the arg_ids
    		  InPat RdrName,			-- to_pat:
    		  LHsExpr RdrName -> LHsExpr RdrName)	-- to_body_fn: takes apart the representation

    -- For example:
    -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
    --				 abc,
    --			         \<body-code> -> case abc of { a :*: bc ->
    --				 	         case bc  of { b :*: c  ->
    --					         <body-code> )

    -- We need to use different uniques in the branches
    -- because the returned to_body_fns are nested.
    -- Hence the returned unqique-name supply

    mk_prod_stuff us []		-- Unit case
      = (us+1,
         nlHsVar genUnitDataCon_RDR,
         noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
    	    	     (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
    	-- Give a signature to the pattern so we get
    	--	data S a = Nil | S a
    	--	toS = \x -> case x of { Inl (g :: Unit) -> Nil
    	--				Inr x -> S x }
    	-- The (:: Unit) signature ensures that we'll infer the right
    	-- type for toS. If we leave it out, the type is too polymorphic

         \x -> x)

    mk_prod_stuff us [arg_var]	-- Singleton case
      = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)

    mk_prod_stuff us arg_vars	-- Two or more
      = (us'',
         nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
         nlVarPat to_arg,
    -- gaw 2004 FIX?
         \x -> noLoc (HsCase (nlHsVar to_arg)
    		  (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
      where
        to_arg = mkGenericLocal us
        (l_arg_vars, r_arg_vars) 		      = splitInHalf arg_vars
        (us',  l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
        (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
        pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]

    splitInHalf :: [a] -> ([a],[a])
    splitInHalf list = (left, right)
    		 where
    		   half  = length list `div` 2
    		   left  = take half list
    		   right = drop half list

    mkGenericLocal :: US -> RdrName
    mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))

    mkGenericNames :: TyCon -> (RdrName, RdrName)
    mkGenericNames tycon
      = (from_RDR, to_RDR)
      where
        tc_name  = tyConName tycon
        tc_occ   = nameOccName tc_name
        tc_mod   = ASSERT( isExternalName tc_name ) nameModule tc_name
        from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
        to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)

\end{code} %************************************************************************ %* * \subsection{Generating the RHS of a generic default method} %* * %************************************************************************ Generating the Generic default method. Uses the bimaps to generate the actual method. All of this is rather incomplete, but it would be nice to make even this work. Example class Foo a where op :: Op a instance Foo T Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs: instance Foo T where op = <mkGenericRhs op a T> To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where toOp :: Op Trep -> Op T fromOp :: Op T -> Op Trep (the bimap) and then fill in the RHS with instance Foo T where op = toOp op Remember, we're generating a RenamedHsExpr, so the result of all this will be fed to the type checker. So the 'op' on the RHS will be at the representation type for T, Trep. Note [Polymorphic methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose the class op is polymorphic: class Baz a where op :: forall b. Ord b => a -> b -> b Then we can still generate a bimap with toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b) and fill in the instance decl thus instance Foo T where op = toOp op By the time the type checker has done its stuff we'll get instance Foo T where op = \b. \dict::Ord b. toOp b (op Trep b dict) Note [Higher rank methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Higher-rank method types don't work, because we'd generate a bimap that needs impredicative polymorphism. In principle that should be possible (with boxy types and all) but it would take a bit of working out. Here's an example: class ChurchEncode k where match :: k -> z -> (forall a b z. a -> b -> z) {- product -} -> (forall a z. a -> z) {- left -} -> (forall a z. a -> z) {- right -} -> z match {| Unit |} Unit unit prod left right = unit match {| a :*: b |} (x :*: y) unit prod left right = prod x y match {| a :+: b |} (Inl l) unit prod left right = left l match {| a :+: b |} (Inr r) unit prod left right = right r \begin{code}

    mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
    mkGenericRhs sel_id tyvar tycon
      = ASSERT( isSingleton ctxt ) 	-- Checks shape of selector-id context
    --    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
        mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
      where
    	-- Initialising the "Environment" with the from/to functions
    	-- on the datatype (actually tycon) in question
    	(from_RDR, to_RDR) = mkGenericNames tycon

            -- Instantiate the selector type, and strip off its class context
    	(ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))

            -- Do it again!  This deals with the case where the method type
    	-- is polymorphic -- see Note [Polymorphic methods] above
    	(local_tvs,_,final_ty) = tcSplitSigmaTy op_ty

    	-- Now we probably have a tycon in front
            -- of us, quite probably a FunTyCon.
            ep    = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
            bimap = generate_bimap (tyvar, ep, local_tvs) final_ty

    type EPEnv = (TyVar,			-- The class type variable
    	      EP (LHsExpr RdrName),	-- The EP it maps to
    	      [TyVar]			-- Other in-scope tyvars; they have an identity EP
    	     )

    -------------------
    generate_bimap :: EPEnv
    	       -> Type
    	       -> EP (LHsExpr RdrName)
    -- Top level case - splitting the TyCon.
    generate_bimap env@(tv,ep,local_tvs) ty
      | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
      = idEP	-- A constant type

      | Just tv1 <- getTyVar_maybe ty
      = ASSERT( tv == tv1 ) ep					-- The class tyvar

      | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
      = bimapTyCon tycon (map (generate_bimap env) ty_args)

      | otherwise
      = pprPanic "generate_bimap" (ppr ty)

    -------------------
    bimapTyCon :: TyCon -> [EP  (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
    bimapTyCon tycon arg_eps
      | tycon == funTyCon       = bimapArrow arg_eps
      | tycon == listTyCon      = bimapList arg_eps
      | isBoxedTupleTyCon tycon = bimapTuple arg_eps
      | otherwise		    = pprPanic "bimapTyCon" (ppr tycon)

    -------------------
    -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
    bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
    bimapArrow [ep1, ep2]
      = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
    	 toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
      where
        from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP   ep1 `mkHsApp` nlHsVar b_RDR))
        to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))

    -------------------
    -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
    bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
    bimapTuple eps
      = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
    	 toEP   = mkHsLam [noLoc tuple_pat] to_body }
      where
        names	= takeList eps gs_RDR
        tuple_pat	= TuplePat (map nlVarPat names) Boxed placeHolderType
        eps_w_names = eps `zip` names
        to_body     = mkLHsTupleExpr [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
        from_body   = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]

    -------------------
    -- bimapList :: EP a b -> EP [a] [b]
    bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
    bimapList [ep]
      = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
    	 toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }

    -------------------
    a_RDR, b_RDR :: RdrName
    a_RDR	= mkVarUnqual (fsLit "a")
    b_RDR	= mkVarUnqual (fsLit "b")

    gs_RDR :: [RdrName]
    gs_RDR	= [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]

    idEP :: EP (LHsExpr RdrName)
    idEP = EP idexpr idexpr
         where
           idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)

\end{code}