Commit 41449965 authored by Gabor Greif's avatar Gabor Greif 💬
Browse files

Untabify and M-x whitespace cleanup

parent 713b271f
......@@ -7,12 +7,6 @@ The deriving code for the Generic class
\begin{code}
{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# OPTIONS_GHC -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
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module TcGenGenerics (canDoGenerics, canDoGenerics1,
......@@ -46,7 +40,7 @@ import BuildTyCl
import SrcLoc
import Bag
import VarSet (elemVarSet)
import Outputable
import Outputable
import FastString
import Util
......@@ -64,7 +58,7 @@ import Control.Monad (mplus,forM)
For the generic representation we need to generate:
\begin{itemize}
\item A Generic instance
\item A Rep type instance
\item A Rep type instance
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}
......@@ -90,7 +84,7 @@ genGenericMetaTyCons tc mod =
mkTyCon name = ASSERT( isExternalName name )
buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
NonRecursive
NonRecursive
False -- Not promotable
False -- Not GADT syntax
NoParentTyCon
......@@ -121,21 +115,21 @@ metaTyConsToDerivStuff tc metaDts =
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 ]
s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
| _ <- x ]
| x <- metaS metaDts ])
fix_env <- getFixityEnv
let
safeOverlap = safeLanguageOn dflags
(dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
mk_inst clas tc dfun_name
mk_inst clas tc dfun_name
= mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
(NoOverlap safeOverlap)
[] clas tys
where
tys = [mkTyConTy tc]
-- Datatype
d_metaTycon = metaD metaDts
d_inst = mk_inst dClas d_metaTycon d_dfun_name
......@@ -144,7 +138,7 @@ metaTyConsToDerivStuff tc metaDts =
, ib_extensions = []
, ib_standalone_deriving = False }
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-- Constructor
c_metaTycons = metaC metaDts
c_insts = [ mk_inst cClas c ds
......@@ -156,7 +150,7 @@ metaTyConsToDerivStuff tc metaDts =
| c <- cBinds ]
c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
| (is,bs) <- myZip1 c_insts c_binds ]
-- Selector
s_metaTycons = metaS metaDts
s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
......@@ -169,15 +163,15 @@ metaTyConsToDerivStuff tc metaDts =
s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is
, iBinds = bs})))
(myZip2 s_insts s_binds)
myZip1 :: [a] -> [b] -> [(a,b)]
myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2
myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
myZip2 l1 l2 =
ASSERT(and (zipWith (>=) (map length l1) (map length l2)))
[ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts)
`unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)
\end{code}
......@@ -286,8 +280,8 @@ canDoGenerics tc tc_args
then (Just (ppr dc <+> text "must be a vanilla data constructor"))
else Nothing)
-- Nor can we do the job if it's an existential data constructor,
-- Nor if the args are polymorphic types (I don't think)
-- 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)
mergeErrors :: [Maybe SDoc] -> Maybe SDoc
......@@ -401,13 +395,13 @@ canDoGenerics1 rep_tc tc_args =
\end{code}
%************************************************************************
%* *
%* *
\subsection{Generating the RHS of a generic default method}
%* *
%* *
%************************************************************************
\begin{code}
type US = Int -- Local unique supply, just a plain Int
type US = Int -- Local unique supply, just a plain Int
type Alt = (LPat RdrName, LHsExpr RdrName)
-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
......@@ -434,7 +428,7 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
-- Bindings for the Generic instance
mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
mkBindsRep gk tycon =
mkBindsRep gk tycon =
unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
`unionBags`
unitBag (mkRdrFunBind (L loc to01_RDR) to_matches)
......@@ -456,7 +450,7 @@ mkBindsRep gk tycon =
Gen1 -> ASSERT(length tyvars >= 1)
Gen1_ (last tyvars)
where tyvars = tyConTyVars tycon
--------------------------------------------------------------------------------
-- The type synonym instance and synonym
-- type instance Rep (D a b) = Rep_D a b
......@@ -468,7 +462,7 @@ tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
-> MetaTyCons -- Metadata datatypes to refer to
-> Module -- Used as the location of the new RepTy
-> TcM (FamInst) -- Generated representation0 coercion
tc_mkRepFamInsts gk tycon metaDts mod =
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 }
......@@ -501,7 +495,7 @@ tc_mkRepFamInsts gk tycon metaDts mod =
-- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
; repTy <- tc_mkRepTy gk_ tycon metaDts
-- `rep_name` is a name we generate for the synonym
; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
......@@ -584,10 +578,10 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
-- The type to generate representation for
-> TyCon
-- Metadata datatypes to refer to
-> MetaTyCons
-> MetaTyCons
-- Generated representation0 type
-> TcM Type
tc_mkRepTy gk_ tycon metaDts =
tc_mkRepTy gk_ tycon metaDts =
do
d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName
......@@ -601,7 +595,7 @@ tc_mkRepTy gk_ tycon metaDts =
plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName
let mkSum' a b = mkTyConApp plus [a,b]
mkProd a b = mkTyConApp times [a,b]
mkComp a b = mkTyConApp comp [a,b]
......@@ -615,7 +609,7 @@ tc_mkRepTy gk_ tycon metaDts =
mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
-- This field has a label
mkS False d a = mkTyConApp s1 [d, a]
-- Sums and products are done in the same way for both Rep and Rep1
sumP [] = mkTyConTy v1
sumP l = ASSERT(length metaCTyCons == length l)
......@@ -630,9 +624,9 @@ tc_mkRepTy gk_ tycon metaDts =
ASSERT(length l == length (metaSTyCons !! i))
foldBal mkProd [ arg d t b
| (d,t) <- zip (metaSTyCons !! i) l ]
arg :: Type -> Type -> Bool -> Type
arg d t b = mkS b d $ case gk_ of
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
......@@ -645,12 +639,12 @@ tc_mkRepTy gk_ tycon metaDts =
argPar argVar = argTyFold argVar $ ArgTyAlg
{ata_rec0 = mkRec0, ata_par1 = mkPar1,
ata_rec1 = mkRec1, ata_comp = mkComp}
metaDTyCon = mkTyConTy (metaD metaDts)
metaCTyCons = map mkTyConTy (metaC metaDts)
metaSTyCons = map (map mkTyConTy) (metaS metaDts)
return (mkD tycon)
--------------------------------------------------------------------------------
......@@ -663,22 +657,22 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
, metaC :: [TyCon]
-- One meta datatype per selector per constructor
, metaS :: [[TyCon]] }
instance Outputable MetaTyCons where
ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
-- Bindings for Datatype, Constructor, and Selector instances
mkBindsMetaD :: FixityEnv -> TyCon
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
mkBag l = foldr1 unionBags
[ unitBag (mkRdrFunBind (L loc name) matches)
| (name, matches) <- l ]
dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches)
......@@ -716,7 +710,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
dtName_matches = mkStringLHS . occNameString . nameOccName
$ tyConName_user
moduleName_matches = mkStringLHS . moduleNameString . moduleName
moduleName_matches = mkStringLHS . moduleNameString . moduleName
. nameModule . tyConName $ tycon
isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
......@@ -777,10 +771,10 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt)
us' = us + n_args
datacon_rdr = getRdrName datacon
from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
-- These M1s are meta-information for the datatype
to_alt_rhs = case gk_ of
......@@ -821,9 +815,9 @@ genLR_E i n e
-- Build a product expression
mkProd_E :: GenericKind_DC -- Generic or Generic1?
-> US -- Base for unique names
-> US -- Base for unique names
-> [(RdrName, Type)] -- List of variables matched on the lhs and their types
-> LHsExpr RdrName -- Resulting product expression
-> LHsExpr RdrName -- Resulting product expression
mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
-- These M1s are meta-information for the constructor
......@@ -847,9 +841,9 @@ wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar v
-- Build a product pattern
mkProd_P :: GenericKind -- Gen0 or Gen1
-> US -- Base for unique names
-> [RdrName] -- List of variables to match
-> LPat RdrName -- Resulting product pattern
-> US -- Base for unique names
-> [RdrName] -- List of variables to match
-> LPat RdrName -- Resulting product pattern
mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
-- These M1s are meta-information for the constructor
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment