Skip to content

GitLab

GHC
GHC
Commit c532c16f authored by dterei's avatar dterei
Browse files
Options

Formatting wibbles.

parent 189f6663
Hide whitespace changes
Inline Side-by-side
Showing with 158 additions and 158 deletions
compiler/main/CmdLineParser.hs
View file @ c532c16f
......@@ -53,7 +53,7 @@ data OptKind m -- Suppose the flag is -f
--------------------------------------------------------
-- The EwM monad
-- The EwM monad
--------------------------------------------------------
type Err = Located String
......@@ -84,7 +84,7 @@ addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
w = "Warning: " ++ msg
deprecate :: Monad m => String -> EwM m ()
deprecate s
deprecate s
= do arg <- getArg
addWarn (arg ++ " is deprecated: " ++ s)
......@@ -146,9 +146,9 @@ processArgs spec args
let b = process rest spare
in (setArg locArg $ action) >> b
Nothing -> process args (locArg : spare)
Nothing -> process args (locArg : spare)
process (arg : args) spare = process args (arg : spare)
process (arg : args) spare = process args (arg : spare)
processOneArg :: OptKind m -> String -> String -> [Located String]
......
compiler/main/DynFlags.hs
View file @ c532c16f
......@@ -81,7 +81,7 @@ module DynFlags (
-- * Compiler configuration suitable for display to the user
compilerInfo
#ifdef GHCI
-- Only in stage 2 can we be sure that the RTS
-- Only in stage 2 can we be sure that the RTS
-- exposes the appropriate runtime boolean
, rtsIsProfiled
#endif
......@@ -384,7 +384,7 @@ data ExtensionFlag
| Opt_DoAndIfThenElse
| Opt_RebindableSyntax
| Opt_ConstraintKinds
| Opt_StandaloneDeriving
| Opt_DeriveDataTypeable
| Opt_DeriveFunctor
......@@ -802,7 +802,7 @@ defaultDynFlags mySettings =
maxSimplIterations = 4,
shouldDumpSimplPhase = Nothing,
ruleCheck = Nothing,
simplTickFactor = 100,
simplTickFactor = 100,
specConstrThreshold = Just 2000,
specConstrCount = Just 3,
liberateCaseThreshold = Just 2000,
......@@ -1303,9 +1303,9 @@ allFlags = map ('-':) $
dynamic_flags :: [Flag (CmdLineP DynFlags)]
dynamic_flags = [
Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect"))
, Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp))
, Flag "F" (NoArg (setDynFlag Opt_Pp))
, Flag "#include"
, Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp))
, Flag "F" (NoArg (setDynFlag Opt_Pp))
, Flag "#include"
(HasArg (\s -> do addCmdlineHCInclude s
addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect"))
, Flag "v" (OptIntSuffix setVerbosity)
......@@ -1338,7 +1338,7 @@ dynamic_flags = [
, Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s})))
, Flag "split-objs"
(NoArg (if can_split
(NoArg (if can_split
then setDynFlag Opt_SplitObjs
else addWarn "ignoring -fsplit-objs"))
......@@ -1532,7 +1532,7 @@ dynamic_flags = [
------ Plugin flags ------------------------------------------------
, Flag "fplugin-opt" (hasArg addPluginModuleNameOption)
, Flag "fplugin" (hasArg addPluginModuleName)
------ Optimisation flags ------------------------------------------
, Flag "O" (noArgM (setOptLevel 1))
, Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead"
......@@ -1646,7 +1646,7 @@ mkFlag turn_on flagPrefix f (name, flag, extra_action)
deprecatedForExtension :: String -> TurnOnFlag -> DynP ()
deprecatedForExtension lang turn_on
= deprecate ("use -X" ++ flag ++ " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead")
where
where
flag | turn_on = lang
| otherwise = "No"++lang
......@@ -1833,11 +1833,11 @@ xFlags = [
( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ),
( "Rank2Types", Opt_Rank2Types, nop ),
( "RankNTypes", Opt_RankNTypes, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "TypeOperators", Opt_TypeOperators, nop ),
( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo'
deprecatedForExtension "DoRec"),
( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
......@@ -1859,7 +1859,7 @@ xFlags = [
( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ),
( "RebindableSyntax", Opt_RebindableSyntax, nop ),
( "ConstraintKinds", Opt_ConstraintKinds, nop ),
( "MonoPatBinds", Opt_MonoPatBinds,
( "MonoPatBinds", Opt_MonoPatBinds,
\ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
( "ExplicitForAll", Opt_ExplicitForAll, nop ),
( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ),
......@@ -1870,15 +1870,15 @@ xFlags = [
( "RelaxedLayout", Opt_RelaxedLayout, nop ),
( "TraditionalRecordSyntax", Opt_TraditionalRecordSyntax, nop ),
( "MonoLocalBinds", Opt_MonoLocalBinds, nop ),
( "RelaxedPolyRec", Opt_RelaxedPolyRec,
\ turn_on -> if not turn_on
( "RelaxedPolyRec", Opt_RelaxedPolyRec,
\ turn_on -> if not turn_on
then deprecate "You can't turn off RelaxedPolyRec any more"
else return () ),
( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, nop ),
( "ImplicitParams", Opt_ImplicitParams, nop ),
( "ScopedTypeVariables", Opt_ScopedTypeVariables, nop ),
( "PatternSignatures", Opt_ScopedTypeVariables,
( "PatternSignatures", Opt_ScopedTypeVariables,
deprecatedForExtension "ScopedTypeVariables" ),
( "UnboxedTuples", Opt_UnboxedTuples, nop ),
......@@ -1903,7 +1903,7 @@ xFlags = [
]
defaultFlags :: [DynFlag]
defaultFlags
defaultFlags
= [ Opt_AutoLinkPackages,
Opt_ReadUserPackageConf,
......@@ -1951,7 +1951,7 @@ impliedFlags
-- stuff like " 'a' not in scope ", which is a bit silly
-- if the compiler has just filled in field 'a' of constructor 'C'
, (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields)
, (Opt_ParallelArrays, turnOn, Opt_ParallelListComp)
]
......@@ -2189,8 +2189,8 @@ setDumpFlag' dump_flag
Opt_D_dump_hi_diffs]
forceRecompile :: DynP ()
-- Whenver we -ddump, force recompilation (by switching off the
-- recompilation checker), else you don't see the dump! However,
-- Whenver we -ddump, force recompilation (by switching off the
-- recompilation checker), else you don't see the dump! However,
-- don't switch it off in --make mode, else *everything* gets
-- recompiled which probably isn't what you want
forceRecompile = do dfs <- liftEwM getCmdLineState
......@@ -2200,7 +2200,7 @@ forceRecompile = do dfs <- liftEwM getCmdLineState
setVerboseCore2Core :: DynP ()
setVerboseCore2Core = do forceRecompile
setDynFlag Opt_D_verbose_core2core
setDynFlag Opt_D_verbose_core2core
upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
setDumpSimplPhases :: String -> DynP ()
......@@ -2313,7 +2313,7 @@ setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend }
-- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax.
--
dphPackageMaybe :: DynFlags -> Maybe PackageId
dphPackageMaybe dflags
dphPackageMaybe dflags
= case dphBackend dflags of
DPHPar -> Just dphParPackageId
DPHSeq -> Just dphSeqPackageId
......
compiler/main/StaticFlagParser.hs
View file @ c532c16f
......@@ -77,7 +77,7 @@ parseStaticFlags args = do
| otherwise = []
-- HACK: -fexcess-precision is both a static and a dynamic flag. If
-- the static flag parser has slurped it, we must return it as a
-- the static flag parser has slurped it, we must return it as a
-- leftover too. ToDo: make -fexcess-precision dynamic only.
let excess_prec
| opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec")
......@@ -104,11 +104,11 @@ static_flags :: [Flag IO]
static_flags = [
------- GHCi -------------------------------------------------------
Flag "ignore-dot-ghci" (PassFlag addOpt)
Flag "ignore-dot-ghci" (PassFlag addOpt)
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
------- ways --------------------------------------------------------
, Flag "prof" (NoArg (addWay WayProf))
, Flag "prof" (NoArg (addWay WayProf))
, Flag "eventlog" (NoArg (addWay WayEventLog))
, Flag "parallel" (NoArg (addWay WayPar))
, Flag "gransim" (NoArg (addWay WayGran))
......@@ -147,7 +147,7 @@ static_flags = [
----- RTS opts ------------------------------------------------------
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
------ Compiler flags -----------------------------------------------
......@@ -159,7 +159,7 @@ static_flags = [
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, Flag "fno-"
(PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
-- Pass all remaining "-f<blah>" options to hsc
, Flag "f" (AnySuffixPred isStaticFlag addOpt)
......
compiler/main/StaticFlags.hs
View file @ c532c16f
......@@ -24,7 +24,7 @@ module StaticFlags (
opt_PprCols,
opt_PprCaseAsLet,
opt_PprStyle_Debug, opt_TraceLevel,
opt_NoDebugOutput,
opt_NoDebugOutput,
-- Suppressing boring aspects of core dumps
opt_SuppressAll,
......@@ -85,7 +85,7 @@ module StaticFlags (
-- For the parser
addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready,
-- Saving/restoring globals
saveStaticFlagGlobals, restoreStaticFlagGlobals
) where
......@@ -119,7 +119,7 @@ addWay = consIORef v_Ways . lkupWay
removeOpt :: String -> IO ()
removeOpt f = do
fs <- readIORef v_opt_C
writeIORef v_opt_C $! filter (/= f) fs
writeIORef v_opt_C $! filter (/= f) fs
lookUp :: FastString -> Bool
lookup_def_int :: String -> Int -> Int
......@@ -147,14 +147,14 @@ packed_static_opts :: [FastString]
packed_static_opts = map mkFastString staticFlags
lookUp sw = sw `elem` packed_static_opts
-- (lookup_str "foo") looks for the flag -foo=X or -fooX,
-- (lookup_str "foo") looks for the flag -foo=X or -fooX,
-- and returns the string X
lookup_str sw
lookup_str sw
= case firstJusts (map (stripPrefix sw) staticFlags) of
Just ('=' : str) -> Just str
Just str -> Just str
Nothing -> Nothing
Nothing -> Nothing
lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where
f ('=' : str) = str
......@@ -198,7 +198,7 @@ unpacked_opts =
opt_IgnoreDotGhci :: Bool
opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci")
opt_GhciScripts :: [String]
opt_GhciScripts = lookup_all_str "-ghci-script"
......@@ -207,13 +207,13 @@ opt_GhciScripts = lookup_all_str "-ghci-script"
-- Except for uniques, as some simplifier phases introduce new varibles that
-- have otherwise identical names.
opt_SuppressAll :: Bool
opt_SuppressAll
opt_SuppressAll
= lookUp (fsLit "-dsuppress-all")
-- | Suppress all coercions, them replacing with '...'
opt_SuppressCoercions :: Bool
opt_SuppressCoercions
= lookUp (fsLit "-dsuppress-all")
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-coercions")
-- | Suppress module id prefixes on variables.
......@@ -230,7 +230,7 @@ opt_SuppressTypeApplications
-- | Suppress info such as arity and unfoldings on identifiers.
opt_SuppressIdInfo :: Bool
opt_SuppressIdInfo
opt_SuppressIdInfo
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-idinfo")
......@@ -254,10 +254,10 @@ opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
-- | Set the maximum width of the dumps
-- If GHC's command line options are bad then the options parser uses the
-- pretty printer display the error message. In this case the staticFlags
-- won't be initialized yet, so we must check for this case explicitly
-- won't be initialized yet, so we must check for this case explicitly
-- and return the default value.
opt_PprCols :: Int
opt_PprCols
opt_PprCols
= unsafePerformIO
$ do ready <- readIORef v_opt_C_ready
if (not ready)
......@@ -287,7 +287,7 @@ opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling")
-- Hpc opts
opt_Hpc :: Bool
opt_Hpc = lookUp (fsLit "-fhpc")
opt_Hpc = lookUp (fsLit "-fhpc")
-- language opts
opt_DictsStrict :: Bool
......@@ -369,7 +369,7 @@ opt_Unregisterised = lookUp (fsLit "-funregisterised")
-- Derived, not a real option. Determines whether we will be compiling
-- info tables that reside just before the entry code, or with an
-- indirection to the entry code. See TABLES_NEXT_TO_CODE in
-- indirection to the entry code. See TABLES_NEXT_TO_CODE in
-- includes/rts/storage/InfoTables.h.
tablesNextToCode :: Bool
tablesNextToCode = not opt_Unregisterised
......@@ -417,7 +417,7 @@ data WayName
GLOBAL_VAR(v_Ways, [] ,[Way])
allowed_combination :: [WayName] -> Bool
allowed_combination way = and [ x `allowedWith` y
allowed_combination way = and [ x `allowedWith` y
| x <- way, y <- way, x < y ]
where
-- Note ordering in these tests: the left argument is
......@@ -448,7 +448,7 @@ getWayFlags = do
if not (allowed_combination (map wayName ways))
then ghcError (CmdLineError $
"combination not supported: " ++
foldr1 (\a b -> a ++ '/':b)
foldr1 (\a b -> a ++ '/':b)
(map wayDesc ways))
else
return (concatMap wayOpts ways)
......@@ -457,13 +457,13 @@ mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
lkupWay :: WayName -> Way
lkupWay w =
lkupWay w =
case listToMaybe (filter ((==) w . wayName) way_details) of
Nothing -> error "findBuildTag"
Just details -> details
isRTSWay :: WayName -> Bool
isRTSWay = wayRTSOnly . lkupWay
isRTSWay = wayRTSOnly . lkupWay
data Way = Way {
wayName :: WayName,
......@@ -496,10 +496,10 @@ way_details =
Way WayDyn "dyn" False "Dynamic"
[ "-DDYNAMIC"
, "-optc-DDYNAMIC"
, "-optc-DDYNAMIC"
#if defined(mingw32_TARGET_OS)
-- On Windows, code that is to be linked into a dynamic library must be compiled
-- with -fPIC. Labels not in the current package are assumed to be in a DLL
-- with -fPIC. Labels not in the current package are assumed to be in a DLL
-- different from the current one.
, "-fPIC"
#elif defined(openbsd_TARGET_OS)
......@@ -518,7 +518,7 @@ way_details =
[ "-DTRACING"
, "-optc-DTRACING" ],
Way WayPar "mp" False "Parallel"
Way WayPar "mp" False "Parallel"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
......@@ -529,7 +529,7 @@ way_details =
, "-optl-lgpvm3" ],
-- at the moment we only change the RTS and could share compiler and libs!
Way WayPar "mt" False "Parallel ticky profiling"
Way WayPar "mt" False "Parallel ticky profiling"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
......@@ -540,7 +540,7 @@ way_details =
, "-optl-lpvm3"
, "-optl-lgpvm3" ],
Way WayPar "md" False "Distributed"
Way WayPar "md" False "Distributed"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-D__DISTRIBUTED_HASKELL__"
......@@ -580,3 +580,4 @@ restoreStaticFlagGlobals (c_ready, c, ways) = do
writeIORef v_opt_C_ready c_ready
writeIORef v_opt_C c
writeIORef v_Ways ways
compiler/typecheck/TcDeriv.lhs
View file @ c532c16f
......@@ -64,7 +64,7 @@ import Control.Monad
Overall plan
~~~~~~~~~~~~
1. Convert the decls (i.e. data/newtype deriving clauses,
1. Convert the decls (i.e. data/newtype deriving clauses,
plus standalone deriving) to [EarlyDerivSpec]
2. Infer the missing contexts for the Left DerivSpecs
......@@ -74,10 +74,10 @@ Overall plan
\begin{code}
-- DerivSpec is purely local to this module
data DerivSpec = DS { ds_loc :: SrcSpan
, ds_orig :: CtOrigin
data DerivSpec = DS { ds_loc :: SrcSpan
, ds_orig :: CtOrigin
, ds_name :: Name
, ds_tvs :: [TyVar]
, ds_tvs :: [TyVar]
, ds_theta :: ThetaType
, ds_cls :: Class
, ds_tys :: [Type]
......@@ -88,7 +88,7 @@ data DerivSpec = DS { ds_loc :: SrcSpan
-- df :: forall tvs. theta => C tys
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the theta
-- For type families, the tycon in
-- For type families, the tycon in
-- in ds_tys is the *family* tycon
-- in ds_tc, ds_tc_args is the *representation* tycon
-- For non-family tycons, both are the same
......@@ -100,7 +100,7 @@ data DerivSpec = DS { ds_loc :: SrcSpan
Example:
newtype instance T [a] = MkT (Tree a) deriving( C s )
==>
==>
axiom T [a] = :RTList a
axiom :RTList a = Tree a
......@@ -115,16 +115,16 @@ type DerivContext = Maybe ThetaType
type EarlyDerivSpec = Either DerivSpec DerivSpec
-- Left ds => the context for the instance should be inferred
-- In this case ds_theta is the list of all the
-- In this case ds_theta is the list of all the
-- constraints needed, such as (Eq [a], Eq a)
-- The inference process is to reduce this to a
-- The inference process is to reduce this to a
-- simpler form (e.g. Eq a)
--
-- Right ds => the exact context for the instance is supplied
--
-- Right ds => the exact context for the instance is supplied
-- by the programmer; it is ds_theta
pprDerivSpec :: DerivSpec -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
ds_cls = c, ds_tys = tys, ds_theta = rhs })
= parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
<+> equals <+> ppr rhs)
......@@ -134,7 +134,7 @@ instance Outputable DerivSpec where
\end{code}
Inferring missing contexts
Inferring missing contexts
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
......@@ -143,7 +143,7 @@ Consider
| C3 (T a a)
deriving (Eq)
[NOTE: See end of these comments for what to do with
[NOTE: See end of these comments for what to do with
data (C a, D b) => T a b = ...
]
......@@ -228,7 +228,7 @@ We will need an instance decl like:
The RealFloat in the context is because the read method for Complex is bound
to construct a Complex, and doing that requires that the argument type is
in RealFloat.
in RealFloat.
But this ain't true for Show, Eq, Ord, etc, since they don't construct
a Complex; they only take them apart.
......@@ -250,13 +250,13 @@ Consider this:
instance C [a] Char
newtype T = T Char deriving( C [a] )
Notice the free 'a' in the deriving. We have to fill this out to
Notice the free 'a' in the deriving. We have to fill this out to
newtype T = T Char deriving( forall a. C [a] )
And then translate it to:
instance C [a] Char => C [a] T where ...
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(See also Trac #1220 for an interesting exchange on newtype
......@@ -382,14 +382,13 @@ renameDeriv is_boot inst_infos bagBinds
; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
; bindLocalNames (collectHsValBinders rn_aux_lhs) $
; bindLocalNames (collectHsValBinders rn_aux_lhs) $
do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
; return (listToBag rn_inst_infos, rn_aux,
dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
where
rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
= return ( info { iBinds = NewTypeDerived coi tc }
......@@ -397,7 +396,7 @@ renameDeriv is_boot inst_infos bagBinds
-- See Note [Newtype deriving and unused constructors]
rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
= -- Bring the right type variables into
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
......@@ -495,8 +494,8 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
------------------------------------------------------------------
deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
tcdTyVars = tv_names,
deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
tcdTyVars = tv_names,
tcdTyPats = ty_pats }))
= setSrcSpan loc $ -- Use the location of the 'deriving' item
tcAddDeclCtxt decl $
......@@ -513,7 +512,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
; let cls_tyvars = classTyVars cls
kind = tyVarKind (last cls_tyvars)
(arg_kinds, _) = splitKindFunTys kind
n_args_to_drop = length arg_kinds
n_args_to_drop = length arg_kinds
n_args_to_keep = tyConArity tc - n_args_to_drop
args_to_drop = drop n_args_to_keep tc_args
inst_ty = mkTyConApp tc (take n_args_to_keep tc_args)
......@@ -521,7 +520,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
`minusVarSet` dropped_tvs
-- Check that the result really is well-kinded
; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
(derivingKindErr tc cls cls_tys kind)
......@@ -529,11 +528,11 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a)
tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
(derivingEtaErr cls cls_tys inst_ty)
-- Check that
-- Check that
-- (a) The data type can be eta-reduced; eg reject:
-- data instance T a a = ... deriving( Monad )
-- (b) The type class args do not mention any of the dropped type
-- variables
-- variables
-- newtype T a s = ... deriving( ST s )
-- Type families can't be partially applied
......@@ -571,7 +570,7 @@ When there are no type families, it's quite easy:
-- :CoS :: S ~ [] -- Eta-reduced
instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
When type familes are involved it's trickier:
......@@ -589,7 +588,7 @@ Henc the current typeFamilyPapErr, even though the instance makes sense.
After all, we can write it out
instance Monad [] => Monad (T Int) -- only if we can eta reduce???
return x = MkT [x]
... etc ...
... etc ...
\begin{code}
mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
......@@ -625,10 +624,10 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
| otherwise
= do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
-- Be careful to test rep_tc here: in the case of families,
-- Be careful to test rep_tc here: in the case of families,
-- we want to check the instance tycon, not the family tycon
-- For standalone deriving (mtheta /= Nothing),
-- For standalone deriving (mtheta /= Nothing),
-- check that all the data constructors are in scope.
; rdr_env <- getGlobalRdrEnv
; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
......@@ -643,7 +642,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
mkDataTypeEqn orig dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
else
mkNewTypeEqn orig dflags tvs cls cls_tys
mkNewTypeEqn orig dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta }
\end{code}
......@@ -660,7 +659,7 @@ mkDataTypeEqn :: CtOrigin
-> [Var] -- Universally quantified type variables in the instance
-> Class -- Class for which we need to derive an instance
-> [Type] -- Other parameters to the class except the last
-> TyCon -- Type constructor for which the instance is requested
-> TyCon -- Type constructor for which the instance is requested
-- (last parameter to the type class)
-> [Type] -- Parameters to the type constructor
-> TyCon -- rep of the above (for type families)
......@@ -679,7 +678,7 @@ mkDataTypeEqn orig dflags tvs cls cls_tys
go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
mk_data_eqn :: CtOrigin -> [TyVar] -> Class
mk_data_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
......@@ -688,7 +687,7 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
; let inst_tys = [mkTyConApp tycon tc_args]
inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
spec = DS { ds_loc = loc, ds_orig = orig
, ds_name = dfun_name, ds_tvs = tvs
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = mtheta `orElse` inferred_constraints
......@@ -698,7 +697,7 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
else Left spec) } -- Infer context
----------------------
mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_typeable_eqn orig tvs cls tycon tc_args mtheta
......@@ -719,7 +718,7 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
| otherwise -- standaone deriving
= do { checkTc (null tc_args)
(ptext (sLit "Derived typeable instance must be of form (Typeable")
(ptext (sLit "Derived typeable instance must be of form (Typeable")
<> int (tyConArity tycon) <+> ppr tycon <> rparen)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
......@@ -746,7 +745,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
where
-- Constraints arising from the arguments of each constructor
con_arg_constraints
= [ mkClassPred cls [arg_ty]
= [ mkClassPred cls [arg_ty]
| data_con <- tyConDataCons rep_tc,
arg_ty <- ASSERT( isVanillaDataCon data_con )
get_constrained_tys $
......@@ -762,7 +761,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
is_functor_like = getUnique cls `elem` functorLikeClassKeys
get_constrained_tys :: [Type] -> [Type]
get_constrained_tys tys
get_constrained_tys tys
| is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
| otherwise = tys
......@@ -779,20 +778,20 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
-- Stupid constraints
stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args