TcGenGenerics.lhs 36.2 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2011
3 4
%

5 6 7
The deriving code for the Generic class
(equivalent to the code in TcGenDeriv, for other classes)

8
\begin{code}
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
9
{-# LANGUAGE ScopedTypeVariables #-}
Ian Lynagh's avatar
Ian Lynagh committed
10 11 12 13
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
14
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
Ian Lynagh's avatar
Ian Lynagh committed
15 16
-- for details

17

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
18 19 20 21
module TcGenGenerics (canDoGenerics, canDoGenerics1,
                      GenericKind(..),
                      MetaTyCons, genGenericMetaTyCons,
                      gen_Generic_binds, get_gen1_constrained_tys) where
22

23
import DynFlags
24
import HsSyn
25
import Type
26
import Kind             ( isKind )
27
import TcType
28
import TcGenDeriv
29 30
import DataCon
import TyCon
31
import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
32
import FamInst
33 34 35
import Module           ( Module, moduleName, moduleNameString )
import IfaceEnv         ( newGlobalBinder )
import Name      hiding ( varName )
36 37 38
import RdrName
import BasicTypes
import TysWiredIn
39
import PrelNames
40 41 42
import InstEnv
import TcEnv
import MkId
43
import TcRnMonad
44
import HscTypes
45
import BuildTyCl
46
import SrcLoc
47
import Bag
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
48
import VarSet (elemVarSet)
49
import Outputable 
50
import FastString
51
import Util
52

53
import Control.Monad (mplus,forM)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
54

55 56 57 58
#include "HsVersions.h"
\end{code}

%************************************************************************
59 60 61 62 63 64 65 66 67 68 69 70 71
%*                                                                      *
\subsection{Bindings for the new generic deriving mechanism}
%*                                                                      *
%************************************************************************

For the generic representation we need to generate:
\begin{itemize}
\item A Generic instance
\item A Rep type instance 
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}

\begin{code}
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
72
gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
73
                 -> TcM (LHsBinds RdrName, FamInst)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
74 75 76 77 78 79
gen_Generic_binds gk tc metaTyCons mod = do
  repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
  return (mkBindsRep gk tc, repTyInsts)

genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff)
genGenericMetaTyCons tc mod =
80
  do  loc <- getSrcSpanM
81 82 83 84
      let
        tc_name   = tyConName tc
        tc_cons   = tyConDataCons tc
        tc_arits  = map dataConSourceArity tc_cons
85

86 87 88 89
        tc_occ    = nameOccName tc_name
        d_occ     = mkGenD tc_occ
        c_occ m   = mkGenC tc_occ m
        s_occ m n = mkGenS tc_occ m n
90

91
        mkTyCon name = ASSERT( isExternalName name )
92
                       buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
93 94 95 96
                                          NonRecursive 
                                          False          -- Not promotable
                                          False          -- Not GADT syntax
                                          NoParentTyCon
97

98 99 100 101 102 103
      d_name  <- newGlobalBinder mod d_occ loc
      c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
                    newGlobalBinder mod (c_occ m) loc
      s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
                    newGlobalBinder mod (s_occ m n) loc

104 105
      let metaDTyCon  = mkTyCon d_name
          metaCTyCons = map mkTyCon c_names
106
          metaSTyCons = map (map mkTyCon) s_names
107

108
          metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
109

110
      -- pprTrace "rep0" (ppr rep0_tycon) $
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
111
      (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
112

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
113 114 115
-- both the tycon declarations and related instances
metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
metaTyConsToDerivStuff tc metaDts =
116
  do  loc <- getSrcSpanM
117
      dflags <- getDynFlags
118 119 120 121 122 123 124 125 126 127 128 129 130
      dClas <- tcLookupClass datatypeClassName
      let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
      d_dfun_name <- new_dfun_name dClas tc
      cClas <- tcLookupClass constructorClassName
      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
      sClas <- tcLookupClass selectorClassName
      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
                                               | _ <- x ] 
                                             | x <- metaS metaDts ])
      fix_env <- getFixityEnv

      let
        safeOverlap = safeLanguageOn dflags
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
131
        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
132 133 134 135 136 137
        mk_inst clas tc dfun_name 
          = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
                            (NoOverlap safeOverlap)
                            [] clas tys
          where
            tys = [mkTyConTy tc]
138 139 140
        
        -- Datatype
        d_metaTycon = metaD metaDts
141
        d_inst   = mk_inst dClas d_metaTycon d_dfun_name
142 143 144
        d_binds  = InstBindings { ib_binds = dBinds
                                , ib_pragmas = []
                                , ib_standalone_deriving = False }
145 146 147 148
        d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
        
        -- Constructor
        c_metaTycons = metaC metaDts
149
        c_insts = [ mk_inst cClas c ds
150
                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
151 152 153 154
        c_binds = [ InstBindings { ib_binds = c
                                 , ib_pragmas = []
                                 , ib_standalone_deriving = False }
                  | c <- cBinds ]
155 156 157 158 159
        c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
                   | (is,bs) <- myZip1 c_insts c_binds ]
        
        -- Selector
        s_metaTycons = metaS metaDts
160 161
        s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
                      (myZip2 s_metaTycons s_dfun_names)
162 163 164 165
        s_binds = [ [ InstBindings { ib_binds = s
                                   , ib_pragmas = []
                                   , ib_standalone_deriving = False }
                    | s <- ss ] | ss <- sBinds ]
166 167 168 169 170
        s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec  = is
                                                             , iBinds = bs})))
                       (myZip2 s_insts s_binds)
       
        myZip1 :: [a] -> [b] -> [(a,b)]
171
        myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2
172 173 174
        
        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
        myZip2 l1 l2 =
175
          ASSERT(and (zipWith (>=) (map length l1) (map length l2)))
176 177
            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
        
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
178 179
      return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts)
               `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)
180 181 182 183
\end{code}

%************************************************************************
%*                                                                      *
184
\subsection{Generating representation types}
185
%*                                                                      *
186 187 188
%************************************************************************

\begin{code}
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
189 190 191 192 193 194 195 196 197
get_gen1_constrained_tys :: TyVar -> [Type] -> [Type]
-- called by TcDeriv.inferConstraints; generates a list of types, each of which
-- must be a Functor in order for the Generic1 instance to work.
get_gen1_constrained_tys argVar =
  concatMap $ argTyFold argVar $ ArgTyAlg {
    ata_rec0 = const [],
    ata_par1 = [], ata_rec1 = const [],
    ata_comp = (:)}

198
{-
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
199

200 201
Note [Requirements for deriving Generic and Rep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
202

203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
In the following, T, Tfun, and Targ are "meta-variables" ranging over type
expressions.

(Generic T) and (Rep T) are derivable for some type expression T if the
following constraints are satisfied.

  (a) T = (D v1 ... vn) with free variables v1, v2, ..., vn where n >= 0 v1
      ... vn are distinct type variables. Cf #5939.

  (b) D is a type constructor *value*. In other words, D is either a type
      constructor or it is equivalent to the head of a data family instance (up to
      alpha-renaming).

  (c) D cannot have a "stupid context".

  (d) The right-hand side of D cannot include unboxed types, existential types,
      or universally quantified types.

  (e) T :: *.

(Generic1 T) and (Rep1 T) are derivable for some type expression T if the
following constraints are satisfied.

  (a),(b),(c),(d) As above.
227

228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
  (f) T must expect arguments, and its last parameter must have kind *.

      We use `a' to denote the parameter of D that corresponds to the last
      parameter of T.

  (g) For any type-level application (Tfun Targ) in the right-hand side of D
      where the head of Tfun is not a tuple constructor:

      (b1) `a' must not occur in Tfun.

      (b2) If `a' occurs in Targ, then Tfun :: * -> *.

-}

canDoGenerics :: TyCon -> [Type] -> Maybe SDoc
-- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a
-- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
--
-- Check (b) from Note [Requirements for deriving Generic and Rep] is taken
-- care of because canDoGenerics is applied to rep tycons.
--
-- It returns Nothing if deriving is possible. It returns (Just reason) if not.
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
250 251
canDoGenerics tc tc_args
  = mergeErrors (
252
          -- Check (c) from Note [Requirements for deriving Generic and Rep].
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
253 254 255
              (if (not (null (tyConStupidTheta tc)))
                then (Just (tc_name <+> text "must not have a datatype context"))
                else Nothing) :
256 257 258 259
          -- Check (a) from Note [Requirements for deriving Generic and Rep].
          --
          -- Data family indices can be instantiated; the `tc_args` here are
          -- the representation tycon args
260
              (if (all isTyVarTy (filterOut isKind tc_args))
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
261 262 263 264
                then Nothing
                else Just (tc_name <+> text "must not be instantiated;" <+>
                           text "try deriving `" <> tc_name <+> tc_tys <>
                           text "' instead"))
265
          -- See comment below
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
266
            : (map bad_con (tyConDataCons tc)))
267
  where
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
268 269 270 271 272
    -- The tc can be a representation tycon. When we want to display it to the
    -- user (in an error message) we should print its parent
    (tc_name, tc_tys) = case tyConParent tc of
        FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
                                            (tys ++ drop (length tys) tc_args)))
273
        _                      -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
274

275 276 277
        -- Check (d) from Note [Requirements for deriving Generic and Rep].
        --
        -- If any of the constructors has an unboxed type as argument,
278 279 280 281
        -- 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
    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
282
                  then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
283
                  else (if (not (isVanillaDataCon dc))
284
                          then (Just (ppr dc <+> text "must be a vanilla data constructor"))
285 286
                          else Nothing)

287
	-- Nor can we do the job if it's an existential data constructor,
288 289
	-- Nor if the args are polymorphic types (I don't think)
    bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
290 291 292 293 294 295 296 297

mergeErrors :: [Maybe SDoc] -> Maybe SDoc
mergeErrors []           = Nothing
mergeErrors ((Just s):t) = case mergeErrors t of
  Nothing -> Just s
  Just s' -> Just (s <> text ", and" $$ s')
mergeErrors (Nothing :t) = mergeErrors t

298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
-- A datatype used only inside of canDoGenerics1. It's the result of analysing
-- a type term.
data Check_for_CanDoGenerics1 = CCDG1
  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in
                                  -- this type?
  , _ccdg1_errors   :: Maybe SDoc -- errors generated by this type
  }

{-

Note [degenerate use of FFoldType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We use foldDataConArgs here only for its ability to treat tuples
specially. foldDataConArgs also tracks covariance (though it assumes all
higher-order type parameters are covariant) and has hooks for special handling
of functions and polytypes, but we do *not* use those.

The key issue is that Generic1 deriving currently offers no sophisticated
support for functions. For example, we cannot handle

  data F a = F ((a -> Int) -> Int)

even though a is occurring covariantly.

In fact, our rule is harsh: a is simply not allowed to occur within the first
argument of (->). We treat (->) the same as any other non-tuple tycon.

326
Unfortunately, this means we have to track "the parameter occurs in this type"
327 328 329 330 331 332 333 334 335 336 337
explicitly, even though foldDataConArgs is also doing this internally.

-}

-- canDoGenerics1 rep_tc tc_args determines if a Generic1/Rep1 can be derived
-- for a type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
--
-- Checks (a) through (d) from Note [Requirements for deriving Generic and Rep]
-- are taken care of by the call to canDoGenerics.
--
-- It returns Nothing if deriving is possible. It returns (Just reason) if not.
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
338
canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc
339 340
canDoGenerics1 rep_tc tc_args =
  canDoGenerics rep_tc tc_args `mplus` additionalChecks
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
341
  where
342 343 344 345 346 347 348
    additionalChecks
        -- check (f) from Note [Requirements for deriving Generic and Rep]
      | null (tyConTyVars rep_tc) = Just $
          ptext (sLit "Data type") <+> quotes (ppr rep_tc)
      <+> ptext (sLit "must have some type parameters")

      | otherwise = mergeErrors $ concatMap check_con data_cons
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
349 350 351

    data_cons = tyConDataCons rep_tc
    check_con con = case check_vanilla con of
352 353
      j@(Just _) -> [j]
      Nothing -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
354 355 356 357 358 359

    bad :: DataCon -> SDoc -> SDoc
    bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg

    check_vanilla :: DataCon -> Maybe SDoc
    check_vanilla con | isVanillaDataCon con = Nothing
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
360
                      | otherwise            = Just (bad con existential)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
361

362 363 364 365 366 367 368 369 370 371 372 373
    bmzero      = CCDG1 False Nothing
    bmbad con s = CCDG1 True $ Just $ bad con s
    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (mplus m1 m2)

    -- check (g) from Note [degenerate use of FFoldType]
    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
    ft_check con = FT
      { ft_triv = bmzero

      , ft_var = caseVar, ft_co_var = caseVar

      -- (component_0,component_1,...,component_n)
374 375 376
      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
                                  then bmbad con wrong_arg
                                  else foldr bmplus bmzero components
377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393

      -- (dom -> rng), where the head of ty is not a tuple tycon
      , ft_fun = \dom rng -> -- cf #8516
          if _ccdg1_hasParam dom
          then bmbad con wrong_arg
          else bmplus dom rng

      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
      -- the parameter of interest does not occur in ty
      , ft_ty_app = \_ arg -> arg

      , ft_bad_app = bmbad con wrong_arg
      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere
      }
      where
        caseVar = CCDG1 True Nothing

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
394

395 396 397
    existential = text "must not have existential arguments"
    wrong_arg   = text "applies a type to an argument involving the last parameter"
               $$ text "but the applied type is not of kind * -> *"
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
398

399
\end{code}
400

401 402 403 404 405 406 407 408
%************************************************************************
%*									*
\subsection{Generating the RHS of a generic default method}
%*									*
%************************************************************************

\begin{code}
type US = Int	-- Local unique supply, just a plain Int
409
type Alt = (LPat RdrName, LHsExpr RdrName)
410

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
-- Generic1 (Gen1).
data GenericKind = Gen0 | Gen1

-- as above, but with a payload of the TyCon's name for "the" parameter
data GenericKind_ = Gen0_ | Gen1_ TyVar

-- as above, but using a single datacon's name for "the" parameter
data GenericKind_DC = Gen0_DC | Gen1_DC TyVar

forgetArgVar :: GenericKind_DC -> GenericKind
forgetArgVar Gen0_DC   = Gen0
forgetArgVar Gen1_DC{} = Gen1

-- When working only within a single datacon, "the" parameter's name should
-- match that datacon's name for it.
gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
gk2gkDC Gen0_   _ = Gen0_DC
gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d



433
-- Bindings for the Generic instance
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
434 435 436
mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
mkBindsRep gk tycon = 
    unitBag (L loc (mkFunBind (L loc from01_RDR) from_matches))
437
  `unionBags`
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
438
    unitBag (L loc (mkFunBind (L loc to01_RDR) to_matches))
439
      where
dreixel's avatar
dreixel committed
440 441
        from_matches  = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
        to_matches    = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
442 443 444
        loc           = srcLocSpan (getSrcLoc tycon)
        datacons      = tyConDataCons tycon

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
445 446 447 448
        (from01_RDR, to01_RDR) = case gk of
                                   Gen0 -> (from_RDR,  to_RDR)
                                   Gen1 -> (from1_RDR, to1_RDR)

449
        -- Recurse over the sum first
450
        from_alts, to_alts :: [Alt]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
451 452 453
        (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
          where gk_ = case gk of
                  Gen0 -> Gen0_
454
                  Gen1 -> ASSERT(length tyvars >= 1)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
455 456
                          Gen1_ (last tyvars)
                    where tyvars = tyConTyVars tycon
457
        
458
--------------------------------------------------------------------------------
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
459
-- The type synonym instance and synonym
460 461 462 463
--       type instance Rep (D a b) = Rep_D a b
--       type Rep_D a b = ...representation type for D ...
--------------------------------------------------------------------------------

464
tc_mkRepFamInsts :: GenericKind     -- Gen0 or Gen1
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
465
               -> TyCon           -- The type to generate representation for
466
               -> MetaTyCons      -- Metadata datatypes to refer to
467
               -> Module          -- Used as the location of the new RepTy
468
               -> TcM (FamInst)   -- Generated representation0 coercion
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
469 470 471 472 473
tc_mkRepFamInsts gk tycon metaDts mod = 
       -- Consider the example input tycon `D`, where data D a b = D_ a
       -- Also consider `R:DInt`, where { data family D x y :: * -> *
       --                               ; data instance D Int a b = D_ a }
  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
474
       fam_tc <- case gk of
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
475 476
         Gen0 -> tcLookupTyCon repTyConName
         Gen1 -> tcLookupTyCon rep1TyConName
477

478
     ; let -- `tyvars` = [a,b]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
479 480
           (tyvars, gk_) = case gk of
             Gen0 -> (all_tyvars, Gen0_)
481
             Gen1 -> ASSERT(not $ null all_tyvars)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
482 483
                     (init all_tyvars, Gen1_ $ last all_tyvars)
             where all_tyvars = tyConTyVars tycon
484

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
485
           tyvar_args = mkTyVarTys tyvars
486

487
           appT :: [Type]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
488 489 490 491 492 493 494 495 496 497 498 499 500 501
           appT = case tyConFamInst_maybe tycon of
                     -- `appT` = D Int a b (data families case)
                     Just (famtycon, apps) ->
                       -- `fam` = D
                       -- `apps` = [Int, a]
                       let allApps = apps ++
                                     drop (length apps + length tyvars
                                           - tyConArity famtycon) tyvar_args
                       in [mkTyConApp famtycon allApps]
                     -- `appT` = D a b (normal case)
                     Nothing -> [mkTyConApp tycon tyvar_args]

       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
     ; repTy <- tc_mkRepTy gk_ tycon metaDts
502 503
    
       -- `rep_name` is a name we generate for the synonym
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
504 505 506
     ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
                   in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
                        (nameSrcSpan (tyConName tycon))
507

508
     ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy
509
     ; newFamInst SynFamilyInst axiom  }
510

511 512 513 514
--------------------------------------------------------------------------------
-- Type representation
--------------------------------------------------------------------------------

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530
-- | See documentation of 'argTyFold'; that function uses the fields of this
-- type to interpret the structure of a type when that type is considered as an
-- argument to a constructor that is being represented with 'Rep1'.
data ArgTyAlg a = ArgTyAlg
  { ata_rec0 :: (Type -> a)
  , ata_par1 :: a, ata_rec1 :: (Type -> a)
  , ata_comp :: (Type -> a -> a)
  }

-- | @argTyFold@ implements a generalised and safer variant of the @arg@
-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
-- is conceptually equivalent to:
--
-- > arg t = case t of
-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
-- >   App f [t'] |
531 532
-- >     representable1 f &&
-- >     t' == argVar        -> Rec1 f
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
533
-- >   App f [t'] |
534 535
-- >     representable1 f &&
-- >     t' has tyvars       -> f :.: (arg t')
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583
-- >   _                     -> Rec0 t
--
-- where @argVar@ is the last type variable in the data type declaration we are
-- finding the representation for.
--
-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
-- @:.:@.
--
-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
-- some data types. The problematic case is when @t@ is an application of a
-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
-- representable1 checks have been relaxed, and others were moved to
-- @canDoGenerics1@.
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
                            ata_par1 = mkPar1, ata_rec1 = mkRec1,
                            ata_comp = mkComp}) =
  -- mkRec0 is the default; use it if there is no interesting structure
  -- (e.g. occurrences of parameters or recursive occurrences)
  \t -> maybe (mkRec0 t) id $ go t where
  go :: Type -> -- type to fold through
        Maybe a -- the result (e.g. representation type), unless it's trivial
  go t = isParam `mplus` isApp where

    isParam = do -- handles parameters
      t' <- getTyVar_maybe t
      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0

    isApp = do -- handles applications
      (phi, beta) <- tcSplitAppTy_maybe t

      let interesting = argVar `elemVarSet` exactTyVarsOfType beta

      -- Does it have no interesting structure to represent?
      if not interesting then Nothing
        else -- Is the argument the parameter? Special case for mkRec1.
          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
            else mkComp phi `fmap` go beta -- It must be a composition.


tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
               GenericKind_
              -- The type to generate representation for
            -> TyCon
584 585 586 587
               -- Metadata datatypes to refer to
            -> MetaTyCons 
               -- Generated representation0 type
            -> TcM Type
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
588
tc_mkRepTy gk_ tycon metaDts = 
589
  do
590 591 592 593 594
    d1    <- tcLookupTyCon d1TyConName
    c1    <- tcLookupTyCon c1TyConName
    s1    <- tcLookupTyCon s1TyConName
    nS1   <- tcLookupTyCon noSelTyConName
    rec0  <- tcLookupTyCon rec0TyConName
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
595 596
    rec1  <- tcLookupTyCon rec1TyConName
    par1  <- tcLookupTyCon par1TyConName
597 598 599
    u1    <- tcLookupTyCon u1TyConName
    v1    <- tcLookupTyCon v1TyConName
    plus  <- tcLookupTyCon sumTyConName
600
    times <- tcLookupTyCon prodTyConName
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
601
    comp  <- tcLookupTyCon compTyConName
602
    
603
    let mkSum' a b = mkTyConApp plus  [a,b]
604
        mkProd a b = mkTyConApp times [a,b]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
605
        mkComp a b = mkTyConApp comp  [a,b]
606
        mkRec0 a   = mkTyConApp rec0  [a]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
607 608
        mkRec1 a   = mkTyConApp rec1  [a]
        mkPar1     = mkTyConTy  par1
609
        mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
610
        mkC  i d a = mkTyConApp c1    [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon)
611 612 613 614 615
                                                 (null (dataConFieldLabels a))]
        -- This field has no label
        mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
        -- This field has a  label
        mkS False d a = mkTyConApp s1 [d, a]
616
        
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
617
        -- Sums and products are done in the same way for both Rep and Rep1
618
        sumP [] = mkTyConTy v1
619
        sumP l  = ASSERT(length metaCTyCons == length l)
620 621
                    foldBal mkSum' [ mkC i d a
                                   | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
622 623
        -- The Bool is True if this constructor has labelled fields
        prod :: Int -> [Type] -> Bool -> Type
624 625
        prod i [] _ = ASSERT(length metaSTyCons > i)
                        ASSERT(length (metaSTyCons !! i) == 0)
626
                          mkTyConTy u1
627 628
        prod i l b  = ASSERT(length metaSTyCons > i)
                        ASSERT(length l == length (metaSTyCons !! i))
629 630
                          foldBal mkProd [ arg d t b
                                         | (d,t) <- zip (metaSTyCons !! i) l ]
631
        
632
        arg :: Type -> Type -> Bool -> Type
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
633 634 635 636 637 638 639 640 641 642 643 644 645
        arg d t b = mkS b d $ case gk_ of 
            -- Here we previously used Par0 if t was a type variable, but we
            -- realized that we can't always guarantee that we are wrapping-up
            -- all type variables in Par0. So we decided to stop using Par0
            -- altogether, and use Rec0 all the time.
                      Gen0_        -> mkRec0 t
                      Gen1_ argVar -> argPar argVar t
          where
            -- Builds argument represention for Rep1 (more complicated due to
            -- the presence of composition).
            argPar argVar = argTyFold argVar $ ArgTyAlg
              {ata_rec0 = mkRec0, ata_par1 = mkPar1,
               ata_rec1 = mkRec1, ata_comp = mkComp}
646
        
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
647
       
648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665
        metaDTyCon  = mkTyConTy (metaD metaDts)
        metaCTyCons = map mkTyConTy (metaC metaDts)
        metaSTyCons = map (map mkTyConTy) (metaS metaDts)
        
    return (mkD tycon)

--------------------------------------------------------------------------------
-- 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
666
  ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
667
                                   
dreixel's avatar
dreixel committed
668 669
metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
670 671 672


-- Bindings for Datatype, Constructor, and Selector instances
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
673
mkBindsMetaD :: FixityEnv -> TyCon 
674 675 676
             -> ( LHsBinds RdrName      -- Datatype instance
                , [LHsBinds RdrName]    -- Constructor instances
                , [[LHsBinds RdrName]]) -- Selector instances
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
677
mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
678 679 680 681
      where
        mkBag l = foldr1 unionBags 
                    [ unitBag (L loc (mkFunBind (L loc name) matches)) 
                        | (name, matches) <- l ]
682 683 684 685
        dtBinds       = mkBag ( [ (datatypeName_RDR, dtName_matches)
                                , (moduleName_RDR, moduleName_matches)]
                              ++ ifElseEmpty (isNewTyCon tycon)
                                [ (isNewtypeName_RDR, isNewtype_matches) ] )
686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710

        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 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

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
711 712 713 714 715 716
        tyConName_user = case tyConFamInst_maybe tycon of
                           Just (ptycon, _) -> tyConName ptycon
                           Nothing          -> tyConName tycon

        dtName_matches     = mkStringLHS . occNameString . nameOccName
                           $ tyConName_user
717 718
        moduleName_matches = mkStringLHS . moduleNameString . moduleName 
                           . nameModule . tyConName $ tycon
719
        isNewtype_matches  = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
720

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
721
        conName_matches     c = mkStringLHS . occNameString . nameOccName
722 723
                              . dataConName $ c
        conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
724
        conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
725

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
726
        selName_matches     s = mkStringLHS (occNameString (nameOccName s))
727 728 729 730 731 732


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

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
733
mkSum :: GenericKind_ -- Generic or Generic1?
Ian Lynagh's avatar
Ian Lynagh committed
734
      -> US          -- Base for generating unique names
735 736 737 738 739 740
      -> 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
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
741
mkSum _ _ tycon [] = ([from_alt], [to_alt])
742
  where
743 744 745 746
    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))
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
747 748 749
    tyConStr   = occNameString (nameOccName (tyConName tycon))
    errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
    errMsgTo   = "No values for empty datatype " ++ tyConStr
750 751

-- Datatype with at least one constructor
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
752 753 754 755
mkSum gk_ us _ datacons =
  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
           | (d,i) <- zip datacons [1..] ]
756 757

-- Build the sum for a particular constructor
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
758 759
mk1Sum :: GenericKind_DC -- Generic or Generic1?
       -> US        -- Base for generating unique names
760 761 762 763 764
       -> 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
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
765
mk1Sum gk_ us i n datacon = (from_alt, to_alt)
766
  where
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
767 768 769 770 771
    gk = forgetArgVar gk_

    -- Existentials already excluded
    argTys = dataConOrigArgTys datacon
    n_args = dataConSourceArity datacon
772

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
773 774
    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
    datacon_vars = map fst datacon_varTys
775 776 777 778 779
    us'          = us + n_args

    datacon_rdr  = getRdrName datacon
    
    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
780
    from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
781
    
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
782
    to_alt     = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
783
                 -- These M1s are meta-information for the datatype
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
784 785 786 787 788 789 790 791 792 793 794 795 796
    to_alt_rhs = case gk_ of
      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
        where
          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
            converter = argTyFold argVar $ ArgTyAlg
              {ata_rec0 = const $ nlHsVar unK1_RDR,
               ata_par1 = nlHsVar unPar1_RDR,
               ata_rec1 = const $ nlHsVar unRec1_RDR,
               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
                                    `nlHsCompose` nlHsVar unComp1_RDR}


797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820

-- 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
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
821 822 823
mkProd_E :: GenericKind_DC      -- Generic or Generic1?
         -> US	            -- Base for unique names
         -> [(RdrName, Type)] -- List of variables matched on the lhs and their types
dreixel's avatar
dreixel committed
824
	 -> LHsExpr RdrName -- Resulting product expression
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
825 826 827
mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)
mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
                     -- These M1s are meta-information for the constructor
828
  where
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
829
    appVars = map (wrapArg_E gk_) varTys
830 831
    prod a b = prodDataCon_RDR `nlHsApps` [a,b]

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
832 833 834 835 836 837 838 839 840 841 842 843 844
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
wrapArg_E Gen0_DC          (var, _)  = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
                         -- This M1 is meta-information for the selector
wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
                         -- This M1 is meta-information for the selector
  where converter = argTyFold argVar $ ArgTyAlg
          {ata_rec0 = const $ nlHsVar k1DataCon_RDR,
           ata_par1 = nlHsVar par1DataCon_RDR,
           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}


845 846

-- Build a product pattern
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
847 848
mkProd_P :: GenericKind   -- Gen0 or Gen1
         -> US		        -- Base for unique names
849 850
	       -> [RdrName]     -- List of variables to match
	       -> LPat RdrName  -- Resulting product pattern
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
851 852 853
mkProd_P _  _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
                     -- These M1s are meta-information for the constructor
854
  where
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
855
    appVars = map (wrapArg_P gk) vars
856
    prod a b = prodDataCon_RDR `nlConPat` [a,b]
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
857 858 859 860 861

wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
                   -- This M1 is meta-information for the selector
wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
862

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

866 867 868 869 870 871
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]

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
872 873 874
nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
nlHsCompose x y = compose_RDR `nlHsApps` [x, y]

875 876 877 878 879 880 881 882 883 884
-- | 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

885
\end{code}