X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FGenerics.lhs;h=6d1a2df72f2ce83e03ce524633b065a1b9a8f4d9;hp=8cbc87940d1829e560dc0b4a7dcc8e5d22b26980;hb=2a26efb65343e31957b043f63c43caf24d5eeb30;hpb=ad94d40948668032189ad22a0ad741ac1f645f50 diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index 8cbc879..6d1a2df 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -3,35 +3,42 @@ % \begin{code} -{-# OPTIONS -w #-} +{-# 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/CodingStyle#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module Generics ( canDoGenerics, mkTyConGenericBinds, - mkGenericRhs, - validGenericInstanceType, validGenericMethodType + mkGenericRhs, + validGenericInstanceType, validGenericMethodType, + mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD, + MetaTyCons(..), metaTyCons2TyCons ) where import HsSyn import Type -import TcHsSyn import TcType import DataCon import TyCon -import Name -import OccName +import Name hiding (varName) +import OccName (varName) +import Module (moduleName, moduleNameString) import RdrName import BasicTypes -import Var +import Var hiding (varName) import VarSet import Id import TysWiredIn import PrelNames +-- For generation of representation types +import TcEnv (tcLookupTyCon) +import TcRnMonad (TcM, newUnique) +import TcMType (newMetaTyVar) +import HscTypes import SrcLoc import Util @@ -39,6 +46,9 @@ import Bag import Outputable import FastString +import Data.List (splitAt) +import Debug.Trace (trace) + #include "HsVersions.h" \end{code} @@ -228,14 +238,18 @@ validGenericMethodType ty %************************************************************************ \begin{code} -canDoGenerics :: [DataCon] -> Bool +canDoGenerics :: ThetaType -> [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 +canDoGenerics stupid_theta data_cons = not (any bad_con data_cons) -- See comment below - && not (null data_cons) -- No values of the type + + -- && not (null data_cons) -- No values of the type + -- JPM: we now support empty datatypes + + && null stupid_theta -- We do not support datatypes with context (for now) where bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) -- If any of the constructor has an unboxed type as argument, @@ -247,6 +261,8 @@ canDoGenerics data_cons -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) + -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it + -- like this for now... \end{code} %************************************************************************ @@ -257,149 +273,381 @@ canDoGenerics data_cons \begin{code} type US = Int -- Local unique supply, just a plain Int -type FromAlt = (LPat RdrName, LHsExpr RdrName) - +type Alt = (LPat RdrName, LHsExpr RdrName) +{- +data GenRep = GenRep { + genBindsFrom0 :: TyCon -> LHsBinds RdrName + , genBindsTo0 :: TyCon -> LHsBinds RdrName + , genBindsFrom1 :: TyCon -> LHsBinds RdrName + , genBindsTo1 :: TyCon -> LHsBinds RdrName + , genBindsModuleName :: TyCon -> LHsBinds RdrName + , genBindsConName :: DataCon -> LHsBinds RdrName + , genBindsConFixity :: DataCon -> LHsBinds RdrName + , genBindsConIsRecord :: DataCon -> LHsBinds RdrName + , genBindsSelName :: DataCon -> Int -> LHsBinds RdrName + } +-} +-- Bindings for the Representable0 instance +mkBindsRep0 :: TyCon -> LHsBinds RdrName +mkBindsRep0 tycon = + unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches)) + `unionBags` + unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches)) + where + from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts] + to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + + -- Recurse over the sum first + from0_alts, to0_alts :: [Alt] + (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons + +-- Disabled 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)) +mkTyConGenericBinds tycon = + {- + unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches)) + `unionBags` + unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches)) + `unionBags` + mkMeta loc tycon + -} + emptyBag +{- 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 + from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts] + to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + (from0_RDR, to0_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]))) + from0_alts, to0_alts :: [Alt] + (from0_alts, to0_alts) = mkSum init_us tycon datacons + init_us = 1 :: US -- Unique supply +-} + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- +{- +mkRep0Ty :: TyCon -> LHsType Name +mkRep0Ty tycon = res + where + res = d1 `nlHsAppTy` (cons datacons) + d1 = nlHsTyVar d1TyConName `nlHsAppTy` nlHsTyVar d1TyConName -- TODO + c1 = nlHsTyVar c1TyConName `nlHsAppTy` nlHsTyVar c1TyConName -- TODO + s1 = nlHsTyVar s1TyConName `nlHsAppTy` nlHsTyVar noSelTyConName -- TODO + plus a b = nlHsTyVar sumTyConName `nlHsAppTy` a `nlHsAppTy` b + times a b = nlHsTyVar prodTyConName `nlHsAppTy` a `nlHsAppTy` b + k1 x = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar x + + datacons = tyConDataCons tycon + n_args datacon = dataConSourceArity datacon + datacon_vars datacon = map mkGenericLocal [1 .. n_args datacon] + + cons ds = c1 `nlHsAppTy` sum ds + sum [] = nlHsTyVar v1TyConName + sum l = foldBal plus (map sel l) + sel d = s1 `nlHsAppTy` prod (dataConOrigArgTys d) + prod [] = nlHsTyVar u1TyConName + prod l = foldBal times (map arg l) + arg :: Type -> LHsType Name + -- TODO + arg t = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar v1TyConName -- TODO +-} + +tc_mkRep0Ty :: -- The type to generate representation for + TyCon + -- Metadata datatypes to refer to + -> MetaTyCons + -- Generated representation0 type + -> TcM Type +tc_mkRep0Ty tycon metaDts = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + rec0 <- tcLookupTyCon rec0TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + noSel <- tcLookupTyCon noSelTyConName + freshTy <- newMetaTyVar TauTv liftedTypeKind + + let mkSum a b = mkTyConApp plus [a,b] + mkProd a b = mkTyConApp times [a,b] + mkRec0 a = mkTyConApp rec0 [a] + mkD a = mkTyConApp d1 [metaDTyCon, sum (tyConDataCons a)] + mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)] + mkS d a = mkTyConApp s1 [d, a] + + sum [] = mkTyConTy v1 + sum l = ASSERT (length metaCTyCons == length l) + foldBal mkSum [ mkC i d a + | (d,(a,i)) <- zip metaCTyCons (zip l [0..]) ] + prod :: Int -> [Type] -> Type + prod i [] = ASSERT (length metaSTyCons > i) + ASSERT (length (metaSTyCons !! i) == 0) + mkTyConTy u1 + prod i l = ASSERT (length metaSTyCons > i) + ASSERT (length l == length (metaSTyCons !! i)) + foldBal mkProd [ arg d a + | (d,a) <- zip (metaSTyCons !! i) l ] + + arg d t = mkS d (mkRec0 t) + + metaDTyCon = mkTyConTy (metaD metaDts) + metaCTyCons = map mkTyConTy (metaC metaDts) + metaSTyCons = map (map mkTyConTy) (metaS metaDts) + + return (mkD tycon) + +tc_mkRep0TyCon :: TyCon -- The type to generate representation for + -> MetaTyCons -- Metadata datatypes to refer to + -> TcM TyCon -- Generated representation0 type +tc_mkRep0TyCon tycon metaDts = +-- Consider the example input tycon `D`, where data D a b = D_ a + do + uniq1 <- newUnique + uniq2 <- newUnique + -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + rep0Ty <- tc_mkRep0Ty tycon metaDts + -- `rep0` = GHC.Generics.Rep0 (type family) + rep0 <- tcLookupTyCon rep0TyConName + + let mod = nameModule (tyConName tycon) + loc = nameSrcSpan (tyConName tycon) + -- `repName` is a name we generate for the synonym + repName = mkExternalName uniq1 mod (mkGenR0 (nameOccName (tyConName tycon))) loc + -- `coName` is a name for the coercion + coName = mkExternalName uniq2 mod (mkGenR0 (nameOccName (tyConName tycon))) loc + -- `tyvars` = [a,b] + tyvars = tyConTyVars tycon + -- `appT` = D a b + appT = [mkTyConApp tycon (mkTyVarTys tyvars)] + -- Result + res = mkSynTyCon repName + -- rep0Ty has kind `kind of D` -> * + (tyConKind tycon `mkArrowKind` liftedTypeKind) + tyvars (SynonymTyCon rep0Ty) + (FamInstTyCon rep0 appT + (mkCoercionTyCon coName (tyConArity tycon) + -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b + (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty))) + + return res + +-------------------------------------------------------------------------------- +-- Meta-information +-------------------------------------------------------------------------------- + +data MetaTyCons = MetaTyCons { -- One meta datatype per dataype + metaD :: TyCon + -- One meta datatype per constructor + , metaC :: [TyCon] + -- One meta datatype per selector per constructor + , metaS :: [[TyCon]] } + +instance Outputable MetaTyCons where + ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s + +metaTyCons2TyCons :: MetaTyCons -> [TyCon] +metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s + + +-- Bindings for Datatype, Constructor, and Selector instances +mkBindsMetaD :: FixityEnv -> TyCon + -> ( LHsBinds RdrName -- Datatype instance + , [LHsBinds RdrName] -- Constructor instances + , [[LHsBinds RdrName]]) -- Selector instances +mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) + where + mkBag l = foldr1 unionBags + [ unitBag (L loc (mkFunBind (L loc name) matches)) + | (name, matches) <- l ] + dtBinds = mkBag [ (datatypeName_RDR, dtName_matches) + , (moduleName_RDR, moduleName_matches)] + + allConBinds = map conBinds datacons + conBinds c = mkBag ( [ (conName_RDR, conName_matches c)] + ++ ifElseEmpty (dataConIsInfix c) + [ (conFixity_RDR, conFixity_matches c) ] + ++ ifElseEmpty (length (dataConFieldLabels c) > 0) + [ (conIsRecord_RDR, conIsRecord_matches c) ] + ++ ifElseEmpty (isTupleCon c) + [(conIsTuple_RDR + ,conIsTuple_matches (dataConTyCon c))] + ) + + ifElseEmpty p x = if p then x else [] + fixity c = case lookupFixity fix_env (dataConName c) of + Fixity n InfixL -> buildFix n leftAssocDataCon_RDR + Fixity n InfixR -> buildFix n rightAssocDataCon_RDR + Fixity n InfixN -> buildFix n notAssocDataCon_RDR + buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc + , nlHsIntLit (toInteger n)] + + allSelBinds = map (map selBinds) datasels + selBinds s = mkBag [(selName_RDR, selName_matches s)] + + loc = srcLocSpan (getSrcLoc tycon) + mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] + datacons = tyConDataCons tycon + datasels = map dataConFieldLabels datacons + + dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName + $ tycon + moduleName_matches = mkStringLHS . moduleNameString . moduleName + . nameModule . tyConName $ tycon + + conName_matches c = mkStringLHS . showPpr . nameOccName + . dataConName $ c + conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] + conIsRecord_matches c = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + -- TODO: check that this works + conIsTuple_matches c = [mkSimpleHsAlt nlWildPat + (nlHsApp (nlHsVar arityDataCon_RDR) + (nlHsIntLit + (toInteger (tupleTyConArity c))))] + + selName_matches s = mkStringLHS (showPpr (nameOccName s)) + + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: US -- Base for generating unique names + -> TyCon -- The type constructor + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _us tycon [] = ([from_alt], [to_alt]) 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, --- \ -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- ) - --- 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))]))) + from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) + to_alt = (mkM1_P nlWildPat, makeError errMsgTo) + -- These M1s are meta-information for the datatype + makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) + errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon + errMsgTo = "No values for empty datatype " ++ showPpr tycon + +-- Datatype with at least one constructor +mkSum us _tycon datacons = + unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum us i n datacon = (from_alt, to_alt) 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 + 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 = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars)) + + to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs) + -- These M1s are meta-information for the datatype + to_alt_rhs = app_exp + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: US -- Base for unique names + -> [RdrName] -- List of variables matched on the lhs + -> LHsExpr RdrName -- Resulting product expression +mkProd_E us [] = mkM1_E (nlHsVar u1DataCon_RDR) +mkProd_E us vars = mkM1_E (foldBal prod appVars) + -- These M1s are meta-information for the constructor + where + appVars = map wrapArg_E vars + prod a b = prodDataCon_RDR `nlHsApps` [a,b] + +-- TODO: Produce a P0 when v is a parameter +wrapArg_E :: RdrName -> LHsExpr RdrName +wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) + -- This M1 is meta-information for the selector + +-- Build a product pattern +mkProd_P :: US -- Base for unique names + -> [RdrName] -- List of variables to match + -> LPat RdrName -- Resulting product pattern +mkProd_P us [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) +mkProd_P us vars = mkM1_P (foldBal prod appVars) + -- These M1s are meta-information for the constructor + where + appVars = map wrapArg_P vars + prod a b = prodDataCon_RDR `nlConPat` [a,b] + +-- TODO: Produce a P0 when v is a parameter +wrapArg_P :: RdrName -> LPat RdrName +wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) + -- This M1 is meta-information for the selector + 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 = nameModule 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) + +mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e + +mkM1_P :: LPat RdrName -> LPat RdrName +mkM1_P p = m1DataCon_RDR `nlConPat` [p] + +-- | Variant of foldr1 for producing balanced lists +foldBal :: (a -> a -> a) -> [a] -> a +foldBal op = foldBal' op (error "foldBal: empty list") + +foldBal' :: (a -> a -> a) -> a -> [a] -> a +foldBal' _ x [] = x +foldBal' _ _ [y] = y +foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l + in foldBal' op x a `op` foldBal' op x b + \end{code} %************************************************************************ @@ -532,6 +780,7 @@ bimapTyCon tycon arg_eps ------------------- -- 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 } @@ -541,25 +790,30 @@ bimapArrow [ep1, ep2] ------------------- -- 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] (noLoc from_body), - toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) } + = 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 = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed - from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed + 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 = mkVarUnqual FSLIT("a") -b_RDR = mkVarUnqual FSLIT("b") +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)