-- for details
module Generics ( canDoGenerics, mkTyConGenericBinds,
- mkGenericRhs,
- validGenericInstanceType, validGenericMethodType
+ mkGenericRhs,
+ validGenericInstanceType, validGenericMethodType,
+ mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+ MetaTyCons(..), metaTyCons2TyCons
) where
import DataCon
import TyCon
-import Name
+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
import Outputable
import FastString
+import Data.List (splitAt)
+import Debug.Trace (trace)
+
#include "HsVersions.h"
\end{code}
%************************************************************************
\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,
-- 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}
%************************************************************************
\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
+ 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
- (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))])))
+ 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
- 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
+ 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))
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}
%************************************************************************
projects / ghc-hetmet.git / blobdiff