summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
authorGeoffrey Mainland <gmainlan@microsoft.com>2013-06-03 13:20:46 +0100
committerGeoffrey Mainland <gmainlan@microsoft.com>2013-06-03 13:20:46 +0100
commita74030299201cf35cad240b9b3f8f6a32546a58a (patch)
treebeb4475e07335372ef781e5b35f1f8587547abde /compiler/rename
parentf39ca2985b6a2e0de397378097d9eb4eed4ffcde (diff)
downloadhaskell-a74030299201cf35cad240b9b3f8f6a32546a58a.tar.gz
Untabify
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnTypes.lhs489
1 files changed, 241 insertions, 248 deletions
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 69921a2de8..d5014172ea 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -4,26 +4,19 @@
\section[RnSource]{Main pass of renamer}
\begin{code}
-{-# 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
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module RnTypes (
- -- Type related stuff
- rnHsType, rnLHsType, rnLHsTypes, rnContext,
+module RnTypes (
+ -- Type related stuff
+ rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsMaybeKind,
- rnHsSigType, rnLHsInstType, rnConDeclFields,
+ rnHsSigType, rnLHsInstType, rnConDeclFields,
newTyVarNameRn,
- -- Precence related stuff
- mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
- checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
+ -- Precence related stuff
+ mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+ checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
- -- Splice related stuff
- rnSplice, checkTH,
+ -- Splice related stuff
+ rnSplice, checkTH,
-- Binding related stuff
bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
@@ -34,7 +27,7 @@ module RnTypes (
import {-# SOURCE #-} RnExpr( rnLExpr )
#ifdef GHCI
import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
-#endif /* GHCI */
+#endif /* GHCI */
import DynFlags
import HsSyn
@@ -49,13 +42,13 @@ import SrcLoc
import NameSet
import Util
-import BasicTypes ( compareFixity, funTyFixity, negateFixity,
- Fixity(..), FixityDirection(..) )
+import BasicTypes ( compareFixity, funTyFixity, negateFixity,
+ Fixity(..), FixityDirection(..) )
import Outputable
import FastString
import Maybes
import Data.List ( nub )
-import Control.Monad ( unless, when )
+import Control.Monad ( unless, when )
#include "HsVersions.h"
\end{code}
@@ -64,20 +57,20 @@ These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.
%*********************************************************
-%* *
+%* *
\subsection{Renaming types}
-%* *
+%* *
%*********************************************************
\begin{code}
rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
- -- rnHsSigType is used for source-language type signatures,
- -- which use *implicit* universal quantification.
+ -- rnHsSigType is used for source-language type signatures,
+ -- which use *implicit* universal quantification.
rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-- Rename the type in an instance or standalone deriving decl
-rnLHsInstType doc_str ty
+rnLHsInstType doc_str ty
= do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
; return (ty', fvs) }
@@ -88,7 +81,7 @@ rnLHsInstType doc_str ty
| otherwise = False
badInstTy :: LHsType RdrName -> SDoc
-badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
+badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
\end{code}
rnHsType is here because we call it from loadInstDecl, and I didn't
@@ -98,7 +91,7 @@ want a gratuitous knot.
rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind
-> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsTyKi isType doc (L loc ty)
- = setSrcSpan loc $
+ = setSrcSpan loc $
do { (ty', fvs) <- rnHsTyKi isType doc ty
; return (L loc ty', fvs) }
@@ -110,9 +103,9 @@ rnLHsKind = rnLHsTyKi False
rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName)
-> RnM (Maybe (LHsKind Name), FreeVars)
-rnLHsMaybeKind _ Nothing
+rnLHsMaybeKind _ Nothing
= return (Nothing, emptyFVs)
-rnLHsMaybeKind doc (Just kind)
+rnLHsMaybeKind doc (Just kind)
= do { (kind', fvs) <- rnLHsKind doc kind
; return (Just kind', fvs) }
@@ -123,15 +116,15 @@ rnHsKind = rnHsTyKi False
rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
+rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
= ASSERT ( isType ) do
- -- Implicit quantifiction in source code (no kinds on tyvars)
- -- Given the signature C => T we universally quantify
- -- over FV(T) \ {in-scope-tyvars}
+ -- Implicit quantifiction in source code (no kinds on tyvars)
+ -- Given the signature C => T we universally quantify
+ -- over FV(T) \ {in-scope-tyvars}
rdr_env <- getLocalRdrEnv
loc <- getSrcSpanM
let
- (forall_kvs, forall_tvs) = filterInScope rdr_env $
+ (forall_kvs, forall_tvs) = filterInScope rdr_env $
extractHsTysRdrTyVars (ty:ctxt)
-- In for-all types we don't bring in scope
-- kind variables mentioned in kind signatures
@@ -139,17 +132,17 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
-- f :: Int -> T (a::k) -- Not allowed
-- The filterInScope is to ensure that we don't quantify over
- -- type variables that are in scope; when GlasgowExts is off,
- -- there usually won't be any, except for class signatures:
- -- class C a where { op :: a -> a }
- tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
+ -- type variables that are in scope; when GlasgowExts is off,
+ -- there usually won't be any, except for class signatures:
+ -- class C a where { op :: a -> a }
+ tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
- = ASSERT ( isType ) do { -- Explicit quantification.
- -- Check that the forall'd tyvars are actually
- -- mentioned in the type, and produce a warning if not
+ = ASSERT ( isType ) do { -- Explicit quantification.
+ -- Check that the forall'd tyvars are actually
+ -- mentioned in the type, and produce a warning if not
let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
@@ -164,17 +157,17 @@ rnHsTyKi isType _ (HsTyVar rdr_name)
-- a sensible error message, but we don't want to complain about the dot too
-- Hence the jiggery pokery with ty1
rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
- = ASSERT ( isType ) setSrcSpan loc $
- do { ops_ok <- xoptM Opt_TypeOperators
- ; op' <- if ops_ok
- then rnTyVar isType op
- else do { addErr (opTyErr op ty)
- ; return (mkUnboundName op) } -- Avoid double complaint
- ; let l_op' = L loc op'
- ; fix <- lookupTyFixityRn l_op'
- ; (ty1', fvs1) <- rnLHsType doc ty1
- ; (ty2', fvs2) <- rnLHsType doc ty2
- ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
+ = ASSERT ( isType ) setSrcSpan loc $
+ do { ops_ok <- xoptM Opt_TypeOperators
+ ; op' <- if ops_ok
+ then rnTyVar isType op
+ else do { addErr (opTyErr op ty)
+ ; return (mkUnboundName op) } -- Avoid double complaint
+ ; let l_op' = L loc op'
+ ; fix <- lookupTyFixityRn l_op'
+ ; (ty1', fvs1) <- rnLHsType doc ty1
+ ; (ty2', fvs2) <- rnLHsType doc ty2
+ ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
op' fix ty1' ty2'
; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
@@ -183,7 +176,7 @@ rnHsTyKi isType doc (HsParTy ty)
; return (HsParTy ty', fvs) }
rnHsTyKi isType doc (HsBangTy b ty)
- = ASSERT ( isType )
+ = ASSERT ( isType )
do { (ty', fvs) <- rnLHsType doc ty
; return (HsBangTy b ty', fvs) }
@@ -195,12 +188,12 @@ rnHsTyKi _ doc ty@(HsRecTy flds)
rnHsTyKi isType doc (HsFunTy ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
- -- Might find a for-all as the arg of a function type
+ -- Might find a for-all as the arg of a function type
; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
- -- Or as the result. This happens when reading Prelude.hi
- -- when we find return :: forall m. Monad m -> forall a. a -> m a
+ -- Or as the result. This happens when reading Prelude.hi
+ -- when we find return :: forall m. Monad m -> forall a. a -> m a
- -- Check for fixity rearrangements
+ -- Check for fixity rearrangements
; res_ty <- if isType
then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
else return (HsFunTy ty1' ty2')
@@ -213,14 +206,14 @@ rnHsTyKi isType doc listTy@(HsListTy ty)
; return (HsListTy ty', fvs) }
rnHsTyKi isType doc (HsKindSig ty k)
- = ASSERT ( isType )
+ = ASSERT ( isType )
do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless kind_sigs_ok (badSigErr False doc ty)
; (ty', fvs1) <- rnLHsType doc ty
; (k', fvs2) <- rnLHsKind doc k
; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
-rnHsTyKi isType doc (HsPArrTy ty)
+rnHsTyKi isType doc (HsPArrTy ty)
= ASSERT ( isType )
do { (ty', fvs) <- rnLHsType doc ty
; return (HsPArrTy ty', fvs) }
@@ -250,18 +243,18 @@ rnHsTyKi isType doc (HsIParamTy n ty)
do { (ty', fvs) <- rnLHsType doc ty
; return (HsIParamTy n ty', fvs) }
-rnHsTyKi isType doc (HsEqTy ty1 ty2)
+rnHsTyKi isType doc (HsEqTy ty1 ty2)
= ASSERT( isType )
do { (ty1', fvs1) <- rnLHsType doc ty1
; (ty2', fvs2) <- rnLHsType doc ty2
; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi isType _ (HsSpliceTy sp _ k)
- = ASSERT ( isType )
- do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
+ = ASSERT ( isType )
+ do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
; return (HsSpliceTy sp' fvs k, fvs) }
-rnHsTyKi isType doc (HsDocTy ty haddock_doc)
+rnHsTyKi isType doc (HsDocTy ty haddock_doc)
= ASSERT ( isType )
do { (ty', fvs) <- rnLHsType doc ty
; haddock_doc' <- rnLHsDoc haddock_doc
@@ -270,19 +263,19 @@ rnHsTyKi isType doc (HsDocTy ty haddock_doc)
#ifndef GHCI
rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
#else
-rnHsTyKi isType doc (HsQuasiQuoteTy qq)
- = ASSERT ( isType )
+rnHsTyKi isType doc (HsQuasiQuoteTy qq)
+ = ASSERT ( isType )
do { ty <- runQuasiQuoteType qq
; rnHsType doc (unLoc ty) }
#endif
-rnHsTyKi isType _ (HsCoreTy ty)
- = ASSERT ( isType )
+rnHsTyKi isType _ (HsCoreTy ty)
+ = ASSERT ( isType )
return (HsCoreTy ty, emptyFVs)
- -- The emptyFVs probably isn't quite right
+ -- The emptyFVs probably isn't quite right
-- but I don't think it matters
-rnHsTyKi _ _ (HsWrapTy {})
+rnHsTyKi _ _ (HsWrapTy {})
= panic "rnHsTyKi"
rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
@@ -292,7 +285,7 @@ rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
; (tys', fvs) <- rnLHsTypes doc tys
; return (HsExplicitListTy k tys', fvs) }
-rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
+rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
= ASSERT( isType )
do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds (addErr (dataKindsErr isType ty))
@@ -314,54 +307,54 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
\begin{code}
-rnForAll :: HsDocContext -> HsExplicitFlag
+rnForAll :: HsDocContext -> HsExplicitFlag
-> [RdrName] -- Kind variables
-> LHsTyVarBndrs RdrName -- Type variables
- -> LHsContext RdrName -> LHsType RdrName
+ -> LHsContext RdrName -> LHsType RdrName
-> RnM (HsType Name, FreeVars)
rnForAll doc exp kvs forall_tyvars ctxt ty
| null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
= rnHsType doc (unLoc ty)
- -- One reason for this case is that a type like Int#
- -- starts off as (HsForAllTy Nothing [] Int), in case
- -- there is some quantification. Now that we have quantified
- -- and discovered there are no type variables, it's nicer to turn
- -- it into plain Int. If it were Int# instead of Int, we'd actually
- -- get an error, because the body of a genuine for-all is
- -- of kind *.
+ -- One reason for this case is that a type like Int#
+ -- starts off as (HsForAllTy Nothing [] Int), in case
+ -- there is some quantification. Now that we have quantified
+ -- and discovered there are no type variables, it's nicer to turn
+ -- it into plain Int. If it were Int# instead of Int, we'd actually
+ -- get an error, because the body of a genuine for-all is
+ -- of kind *.
| otherwise
= bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
do { (new_ctxt, fvs1) <- rnContext doc ctxt
; (new_ty, fvs2) <- rnLHsType doc ty
; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
- -- Retain the same implicit/explicit flag as before
- -- so that we can later print it correctly
+ -- Retain the same implicit/explicit flag as before
+ -- so that we can later print it correctly
---------------
bindSigTyVarsFV :: [Name]
- -> RnM (a, FreeVars)
- -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
-- Used just before renaming the defn of a function
-- with a separate type signature, to bring its tyvars into scope
-- With no -XScopedTypeVariables, this is a no-op
bindSigTyVarsFV tvs thing_inside
- = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
- ; if not scoped_tyvars then
- thing_inside
- else
- bindLocalNamesFV tvs thing_inside }
+ = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside
+ else
+ bindLocalNamesFV tvs thing_inside }
---------------
-bindHsTyVars :: HsDocContext
+bindHsTyVars :: HsDocContext
-> Maybe a -- Just _ => an associated type decl
-> [RdrName] -- Kind variables from scope
-> LHsTyVarBndrs RdrName -- Type variables
-> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
--- (a) Bring kind variables into scope
--- both (i) passed in (kv_bndrs)
+-- (a) Bring kind variables into scope
+-- both (i) passed in (kv_bndrs)
-- and (ii) mentioned in the kinds of tv_bndrs
-- (b) Bring type variables into scope
bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
@@ -378,26 +371,26 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
-- We disallow this: too confusing!
; poly_kind <- xoptM Opt_PolyKinds
- ; unless (poly_kind || null all_kvs)
+ ; unless (poly_kind || null all_kvs)
(addErr (badKindBndrs doc all_kvs))
- ; unless (null overlap_kvs)
+ ; unless (null overlap_kvs)
(addErr (overlappingKindVars doc overlap_kvs))
; loc <- getSrcSpanM
; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
- ; bindLocalNamesFV kv_names $
+ ; bindLocalNamesFV kv_names $
do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
- rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
- rn_tv_bndr (L loc (UserTyVar rdr))
- = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
- ; return (L loc (UserTyVar nm), emptyFVs) }
- rn_tv_bndr (L loc (KindedTyVar rdr kind))
- = do { sig_ok <- xoptM Opt_KindSignatures
+ rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
+ rn_tv_bndr (L loc (UserTyVar rdr))
+ = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+ ; return (L loc (UserTyVar nm), emptyFVs) }
+ rn_tv_bndr (L loc (KindedTyVar rdr kind))
+ = do { sig_ok <- xoptM Opt_KindSignatures
; unless sig_ok (badSigErr False doc kind)
; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
- ; (kind', fvs) <- rnLHsKind doc kind
- ; return (L loc (KindedTyVar nm kind'), fvs) }
+ ; (kind', fvs) <- rnLHsKind doc kind
+ ; return (L loc (KindedTyVar nm kind'), fvs) }
-- Check for duplicate or shadowed tyvar bindrs
; checkDupRdrNames tv_names_w_loc
@@ -414,8 +407,8 @@ newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
newTyVarNameRn mb_assoc rdr_env loc rdr
| Just _ <- mb_assoc -- Use the same Name as the parent class decl
, Just n <- lookupLocalRdrEnv rdr_env rdr
- = return n
- | otherwise
+ = return n
+ | otherwise
= newLocalBndrRn (L loc rdr)
--------------------------------
@@ -432,16 +425,16 @@ rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
, not (tv `elemLocalRdrEnv` name_env) ]
; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
, not (kv `elemLocalRdrEnv` name_env) ]
- ; bindLocalNamesFV kv_names $
- bindLocalNamesFV tv_names $
+ ; bindLocalNamesFV kv_names $
+ bindLocalNamesFV tv_names $
do { (ty', fvs1) <- rnLHsType doc ty
; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
; return (res, fvs1 `plusFV` fvs2) } }
overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
overlappingKindVars doc kvs
- = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
- ptext (sLit "also used as type variable") <> plural kvs
+ = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
+ ptext (sLit "also used as type variable") <> plural kvs
<> colon <+> pprQuotedList kvs
, docOfHsDocContext doc ]
@@ -455,7 +448,7 @@ badKindBndrs doc kvs
badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
badSigErr is_type doc (L loc ty)
= setSrcSpan loc $ addErr $
- vcat [ hang (ptext (sLit "Illegal") <+> what
+ vcat [ hang (ptext (sLit "Illegal") <+> what
<+> ptext (sLit "signature:") <+> quotes (ppr ty))
2 (ptext (sLit "Perhaps you intended to use") <+> flag)
, docOfHsDocContext doc ]
@@ -474,14 +467,14 @@ dataKindsErr is_type thing
| otherwise = ptext (sLit "kind")
\end{code}
-Note [Renaming associated types]
+Note [Renaming associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check that the RHS of the decl mentions only type variables
bound on the LHS. For example, this is not ok
class C a b where
type F a x :: *
instance C (p,q) r where
- type F (p,q) x = (x, r) -- BAD: mentions 'r'
+ type F (p,q) x = (x, r) -- BAD: mentions 'r'
c.f. Trac #5515
What makes it tricky is that the *kind* variable from the class *are*
@@ -489,8 +482,8 @@ in scope (Trac #5862):
class Category (x :: k -> k -> *) where
type Ob x :: k -> Constraint
id :: Ob x a => x a a
- (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
-Here 'k' is in scope in the kind signature even though it's not
+ (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
+Here 'k' is in scope in the kind signature even though it's not
explicitly mentioned on the LHS of the type Ob declaration.
We could force you to mention k explicitly, thus
@@ -500,13 +493,13 @@ but it seems tiresome to do so.
%*********************************************************
-%* *
+%* *
\subsection{Contexts and predicates}
-%* *
+%* *
%*********************************************************
\begin{code}
-rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
+rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
-> RnM ([ConDeclField Name], FreeVars)
rnConDeclFields doc fields = mapFvRn (rnField doc) fields
@@ -518,16 +511,16 @@ rnField doc (ConDeclField name ty haddock_doc)
; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
-rnContext doc (L loc cxt)
+rnContext doc (L loc cxt)
= do { (cxt', fvs) <- rnLHsTypes doc cxt
; return (L loc cxt', fvs) }
\end{code}
%************************************************************************
-%* *
- Fixities and precedence parsing
-%* *
+%* *
+ Fixities and precedence parsing
+%* *
%************************************************************************
@mkOpAppRn@ deals with operator fixities. The argument expressions
@@ -540,9 +533,9 @@ operator application. Why? Because the parser parses all
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
Infix types are read in a *right-associative* way, so that
- a `op` b `op` c
+ a `op` b `op` c
is always read in as
- a `op` (b `op` c)
+ a `op` (b `op` c)
mkHsOpTyRn rearranges where necessary. The two arguments
have already been renamed and rearranged. It's made rather tiresome
@@ -552,46 +545,46 @@ by the presence of ->, which is a separate syntactic construct.
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
- -> Name -> Fixity -> LHsType Name -> LHsType Name
- -> RnM (HsType Name)
+ -> Name -> Fixity -> LHsType Name -> LHsType Name
+ -> RnM (HsType Name)
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
= do { fix2 <- lookupTyFixityRn op2
- ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
- (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
- (unLoc op2) fix2 ty21 ty22 loc2 }
+ ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
+ (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
+ (unLoc op2) fix2 ty21 ty22 loc2 }
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
- = mk_hs_op_ty mk1 pp_op1 fix1 ty1
- HsFunTy funTyConName funTyFixity ty21 ty22 loc2
+ = mk_hs_op_ty mk1 pp_op1 fix1 ty1
+ HsFunTy funTyConName funTyFixity ty21 ty22 loc2
-mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
+mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
= return (mk1 ty1 ty2)
---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
- -> Name -> Fixity -> LHsType Name
- -> (LHsType Name -> LHsType Name -> HsType Name)
- -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
- -> RnM (HsType Name)
-mk_hs_op_ty mk1 op1 fix1 ty1
- mk2 op2 fix2 ty21 ty22 loc2
+ -> Name -> Fixity -> LHsType Name
+ -> (LHsType Name -> LHsType Name -> HsType Name)
+ -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
+ -> RnM (HsType Name)
+mk_hs_op_ty mk1 op1 fix1 ty1
+ mk2 op2 fix2 ty21 ty22 loc2
| nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
- ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
+ ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
| associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
- | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
- new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
- ; return (mk2 (noLoc new_ty) ty22) }
+ | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
+ new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
+ ; return (mk2 (noLoc new_ty) ty22) }
where
(nofix_error, associate_right) = compareFixity fix1 fix2
---------------------------
-mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
- -> LHsExpr Name -> Fixity -- Operator and fixity
- -> LHsExpr Name -- Right operand (not an OpApp, but might
- -- be a NegApp)
- -> RnM (HsExpr Name)
+mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
+ -> LHsExpr Name -> Fixity -- Operator and fixity
+ -> LHsExpr Name -- Right operand (not an OpApp, but might
+ -- be a NegApp)
+ -> RnM (HsExpr Name)
-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
@@ -607,13 +600,13 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
(nofix_error, associate_right) = compareFixity fix1 fix2
---------------------------
--- (- neg_arg) `op` e2
+-- (- neg_arg) `op` e2
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
| nofix_error
= do precParseErr (negateName,negateFixity) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2)
- | associate_right
+ | associate_right
= do new_e <- mkOpAppRn neg_arg op2 fix2 e2
return (NegApp (L loc' new_e) neg_name)
where
@@ -621,19 +614,19 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
(nofix_error, associate_right) = compareFixity negateFixity fix2
---------------------------
--- e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
- | not associate_right -- We *want* right association
+-- e1 `op` - neg_arg
+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
+ | not associate_right -- We *want* right association
= do precParseErr (get_op op1, fix1) (negateName, negateFixity)
return (OpApp e1 op1 fix1 e2)
where
(_, associate_right) = compareFixity fix1 negateFixity
---------------------------
--- Default case
-mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
+-- Default case
+mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
= ASSERT2( right_op_ok fix (unLoc e2),
- ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
+ ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
return (OpApp e1 op fix e2)
@@ -642,7 +635,7 @@ get_op :: LHsExpr Name -> Name
get_op (L _ (HsVar n)) = n
get_op other = pprPanic "get_op" (ppr other)
--- Parser left-associates everything, but
+-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
-- in the right operarand. So we just check that the right operand is OK
right_op_ok :: Fixity -> HsExpr Name -> Bool
@@ -662,17 +655,17 @@ mkNegAppRn neg_arg neg_name
not_op_app :: HsExpr id -> Bool
not_op_app (OpApp _ _ _ _) = False
-not_op_app _ = True
+not_op_app _ = True
---------------------------
-mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
- -> LHsExpr Name -> Fixity -- Operator and fixity
- -> LHsCmdTop Name -- Right operand (not an infix)
- -> RnM (HsCmd Name)
+mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
+ -> LHsExpr Name -> Fixity -- Operator and fixity
+ -> LHsCmdTop Name -- Right operand (not an infix)
+ -> RnM (HsCmd Name)
-- (e11 `op1` e12) `op2` e2
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
- op2 fix2 a2
+ op2 fix2 a2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (HsCmdArrForm op2 (Just fix2) [a1, a2])
@@ -680,40 +673,40 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _
| associate_right
= do new_c <- mkOpFormRn a12 op2 fix2 a2
return (HsCmdArrForm op1 (Just fix1)
- [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])])
- -- TODO: locs are wrong
+ [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])])
+ -- TODO: locs are wrong
where
(nofix_error, associate_right) = compareFixity fix1 fix2
--- Default case
-mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
+-- Default case
+mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
= return (HsCmdArrForm op (Just fix) [arg1, arg2])
--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
- -> RnM (Pat Name)
+ -> RnM (Pat Name)
mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
- = do { fix1 <- lookupFixityRn (unLoc op1)
- ; let (nofix_error, associate_right) = compareFixity fix1 fix2
+ = do { fix1 <- lookupFixityRn (unLoc op1)
+ ; let (nofix_error, associate_right) = compareFixity fix1 fix2
- ; if nofix_error then do
- { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
- ; return (ConPatIn op2 (InfixCon p1 p2)) }
+ ; if nofix_error then do
+ { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
+ ; return (ConPatIn op2 (InfixCon p1 p2)) }
- else if associate_right then do
- { new_p <- mkConOpPatRn op2 fix2 p12 p2
- ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
- else return (ConPatIn op2 (InfixCon p1 p2)) }
+ else if associate_right then do
+ { new_p <- mkConOpPatRn op2 fix2 p12 p2
+ ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
+ else return (ConPatIn op2 (InfixCon p1 p2)) }
-mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
+mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
= ASSERT( not_op_pat (unLoc p2) )
return (ConPatIn op (InfixCon p1 p2))
not_op_pat :: Pat Name -> Bool
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
-not_op_pat _ = True
+not_op_pat _ = True
--------------------------------------
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
@@ -721,36 +714,36 @@ checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
-- eg a `op` b `C` c = ...
-- See comments with rnExpr (OpApp ...) about "deriving"
-checkPrecMatch op (MG { mg_alts = ms })
- = mapM_ check ms
+checkPrecMatch op (MG { mg_alts = ms })
+ = mapM_ check ms
where
check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
- check _ = return ()
- -- This can happen. Consider
- -- a `op` True = ...
- -- op = ...
- -- The infix flag comes from the first binding of the group
- -- but the second eqn has no args (an error, but not discovered
- -- until the type checker). So we don't want to crash on the
- -- second eqn.
+ check _ = return ()
+ -- This can happen. Consider
+ -- a `op` True = ...
+ -- op = ...
+ -- The infix flag comes from the first binding of the group
+ -- but the second eqn has no args (an error, but not discovered
+ -- until the type checker). So we don't want to crash on the
+ -- second eqn.
checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
let
- inf_ok = op1_prec > op_prec ||
- (op1_prec == op_prec &&
- (op1_dir == InfixR && op_dir == InfixR && right ||
- op1_dir == InfixL && op_dir == InfixL && not right))
-
- info = (op, op_fix)
- info1 = (unLoc op1, op1_fix)
- (infol, infor) = if right then (info, info1) else (info1, info)
+ inf_ok = op1_prec > op_prec ||
+ (op1_prec == op_prec &&
+ (op1_dir == InfixR && op_dir == InfixR && right ||
+ op1_dir == InfixL && op_dir == InfixL && not right))
+
+ info = (op, op_fix)
+ info1 = (unLoc op1, op1_fix)
+ (infol, infor) = if right then (info, info1) else (info1, info)
unless inf_ok (precParseErr infol infor)
checkPrec _ _ _
@@ -761,56 +754,56 @@ checkPrec _ _ _
-- (a) its precedence must be higher than that of op
-- (b) its precedency & associativity must be the same as that of op
checkSectionPrec :: FixityDirection -> HsExpr RdrName
- -> LHsExpr Name -> LHsExpr Name -> RnM ()
+ -> LHsExpr Name -> LHsExpr Name -> RnM ()
checkSectionPrec direction section op arg
= case unLoc arg of
- OpApp _ op fix _ -> go_for_it (get_op op) fix
- NegApp _ _ -> go_for_it negateName negateFixity
- _ -> return ()
+ OpApp _ op fix _ -> go_for_it (get_op op) fix
+ NegApp _ _ -> go_for_it negateName negateFixity
+ _ -> return ()
where
op_name = get_op op
go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
- unless (op_prec < arg_prec
- || (op_prec == arg_prec && direction == assoc))
- (sectionPrecErr (op_name, op_fix)
- (arg_op, arg_fix) section)
+ unless (op_prec < arg_prec
+ || (op_prec == arg_prec && direction == assoc))
+ (sectionPrecErr (op_name, op_fix)
+ (arg_op, arg_fix) section)
\end{code}
Precedence-related error messages
\begin{code}
precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
-precParseErr op1@(n1,_) op2@(n2,_)
+precParseErr op1@(n1,_) op2@(n2,_)
| isUnboundName n1 || isUnboundName n2
- = return () -- Avoid error cascade
+ = return () -- Avoid error cascade
| otherwise
= addErr $ hang (ptext (sLit "Precedence parsing error"))
- 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
- ppr_opfix op2,
- ptext (sLit "in the same infix expression")])
+ 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
+ ppr_opfix op2,
+ ptext (sLit "in the same infix expression")])
sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
sectionPrecErr op@(n1,_) arg_op@(n2,_) section
| isUnboundName n1 || isUnboundName n2
- = return () -- Avoid error cascade
+ = return () -- Avoid error cascade
| otherwise
= addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
- nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
- nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
- nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
+ nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
+ nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
+ nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
ppr_opfix :: (Name, Fixity) -> SDoc
ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
where
pp_op | op == negateName = ptext (sLit "prefix `-'")
- | otherwise = quotes (ppr op)
+ | otherwise = quotes (ppr op)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Errors}
-%* *
+%* *
%*********************************************************
\begin{code}
@@ -822,7 +815,7 @@ warnUnusedForAlls in_doc bound mentioned_rdrs
bound_names = hsLTyVarLocNames bound
bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
- add_warn (L loc tv)
+ add_warn (L loc tv)
= addWarnAt loc $
vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
, in_doc ]
@@ -830,30 +823,30 @@ warnUnusedForAlls in_doc bound mentioned_rdrs
opTyErr :: RdrName -> HsType RdrName -> SDoc
opTyErr op ty@(HsOpTy ty1 _ _)
= hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
- 2 extra
+ 2 extra
where
extra | op == dot_tv_RDR && forall_head ty1
- = perhapsForallMsg
- | otherwise
- = ptext (sLit "Use -XTypeOperators to allow operators in types")
+ = perhapsForallMsg
+ | otherwise
+ = ptext (sLit "Use -XTypeOperators to allow operators in types")
forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
forall_head (L _ (HsAppTy ty _)) = forall_head ty
- forall_head _other = False
+ forall_head _other = False
opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
\end{code}
%*********************************************************
-%* *
- Splices
-%* *
+%* *
+ Splices
+%* *
%*********************************************************
Note [Splices]
~~~~~~~~~~~~~~
Consider
- f = ...
- h = ...$(thing "f")...
+ f = ...
+ h = ...$(thing "f")...
The splice can expand into literally anything, so when we do dependency
analysis we must assume that it might mention 'f'. So we simply treat
@@ -871,30 +864,30 @@ type checker. Not very satisfactory really.
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice n expr)
- = do { checkTH expr "splice"
- ; loc <- getSrcSpanM
- ; n' <- newLocalBndrRn (L loc n)
- ; (expr', fvs) <- rnLExpr expr
+ = do { checkTH expr "splice"
+ ; loc <- getSrcSpanM
+ ; n' <- newLocalBndrRn (L loc n)
+ ; (expr', fvs) <- rnLExpr expr
- -- Ugh! See Note [Splices] above
- ; lcl_rdr <- getLocalRdrEnv
- ; gbl_rdr <- getGlobalRdrEnv
- ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
- isLocalGRE gre]
- lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
+ -- Ugh! See Note [Splices] above
+ ; lcl_rdr <- getLocalRdrEnv
+ ; gbl_rdr <- getGlobalRdrEnv
+ ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
+ isLocalGRE gre]
+ lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
- ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+ ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
checkTH :: Outputable a => a -> String -> RnM ()
-#ifdef GHCI
-checkTH _ _ = return () -- OK
+#ifdef GHCI
+checkTH _ _ = return () -- OK
#else
-checkTH e what -- Raise an error in a stage-1 compiler
- = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
- ptext (sLit "requires GHC with interpreter support"),
+checkTH e what -- Raise an error in a stage-1 compiler
+ = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
+ ptext (sLit "requires GHC with interpreter support"),
ptext (sLit "Perhaps you are using a stage-1 compiler?"),
- nest 2 (ppr e)])
-#endif
+ nest 2 (ppr e)])
+#endif
\end{code}
%************************************************************************
@@ -925,7 +918,7 @@ recently, kind variables. For example:
* type instance F (T (a :: Maybe k)) = ...a...k...
Here we want to constrain the kind of 'a', and bind 'k'.
-In general we want to walk over a type, and find
+In general we want to walk over a type, and find
* Its free type variables
* The free kind variables of any kind signatures in the type
@@ -936,7 +929,7 @@ See also Note [HsBSig binder lists] in HsTypes
type FreeKiTyVars = ([RdrName], [RdrName])
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
-filterInScope rdr_env (kvs, tvs)
+filterInScope rdr_env (kvs, tvs)
= (filterOut in_scope kvs, filterOut in_scope tvs)
where
in_scope tv = tv `elemLocalRdrEnv` rdr_env
@@ -946,13 +939,13 @@ extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
-- or the free (sort, kind) variables of a HsKind
-- It's used when making the for-alls explicit.
-- See Note [Kind and type-variable binders]
-extractHsTyRdrTyVars ty
+extractHsTyRdrTyVars ty
= case extract_lty ty ([],[]) of
(kvs, tvs) -> (nub kvs, nub tvs)
extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
-- See Note [Kind and type-variable binders]
-extractHsTysRdrTyVars ty
+extractHsTysRdrTyVars ty
= case extract_ltys ty ([],[]) of
(kvs, tvs) -> (nub kvs, nub tvs)
@@ -1024,7 +1017,7 @@ extract_lty (L _ ty) acc
extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
-> FreeKiTyVars -> FreeKiTyVars
-extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
+extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
(acc_kvs, acc_tvs) -- Note accumulator comes first
(body_kvs, body_tvs)
| null tvs