PostTcType replaced with TypeAnnot
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 5 Sep 2014 23:11:04 +0000 (18:11 -0500)
committerAustin Seipp <austin@well-typed.com>
Sat, 6 Sep 2014 15:36:50 +0000 (10:36 -0500)
Summary:
This is a first step toward allowing generic traversals of the AST without 'landmines', by removing the `panic`s located throughout `placeHolderType`, `placeHolderKind` & co.

See more on the discussion at https://www.mail-archive.com/ghc-devs@haskell.org/msg05564.html

(This also makes a corresponding update to the `haddock` submodule.)

Test Plan: `sh validate` and new tests pass.

Reviewers: austin, simonpj, goldfire

Reviewed By: austin, simonpj, goldfire

Subscribers: edsko, Fuuzetsu, thomasw, holzensp, goldfire, simonmar, relrod, ezyang, carter

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D157

44 files changed:
compiler/deSugar/Check.lhs
compiler/deSugar/DsExpr.lhs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsExpr.lhs-boot
compiler/hsSyn/HsLit.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsPat.lhs-boot
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/hsSyn/PlaceHolder.hs [new file with mode: 0644]
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnSplice.lhs
compiler/rename/RnSplice.lhs-boot
compiler/rename/RnTypes.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcPatSyn.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcTyClsDecls.lhs
testsuite/tests/ghc-api/landmines/.gitignore [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/Makefile [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/MineFixity.hs [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/MineKind.hs [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/MineNames.hs [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/MineType.hs [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/all.T [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/landmines.hs [new file with mode: 0644]
testsuite/tests/ghc-api/landmines/landmines.stdout [new file with mode: 0644]
utils/haddock

index e07a70f..3e6912f 100644 (file)
@@ -220,7 +220,7 @@ check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
    = ([], unitUniqSet n)        -- One eqn, which can't fail
 
    | first_eqn_all_vars && null rs      -- One eqn, but it can fail
-   = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
+   = ([(takeList ps (repeat nlWildPatName),[])], unitUniqSet n)
 
    | first_eqn_all_vars         -- Several eqns, first can fail
    = (pats, addOneToUniqSet indexs n)
@@ -281,7 +281,8 @@ process_literals used_lits qs
        default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
                          [remove_var q | q <- qs, is_var (firstPatN q)]
        (pats',indexs') = check' default_eqns
-       pats_default    = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
+       pats_default    = [(nlWildPatName:ps,constraints) |
+                                        (ps,constraints) <- (pats')] ++ pats
        indexs_default  = unionUniqSets indexs' indexs
 \end{code}
 
@@ -326,9 +327,10 @@ nothing to do.
 
 \begin{code}
 first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
-first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
-                          where
-                            (pats, indexs) = check' (map remove_var qs)
+first_column_only_vars qs
+  = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs)
+  where
+    (pats, indexs) = check' (map remove_var qs)
 \end{code}
 
 This equation takes a matrix of patterns and split the equations by
@@ -400,7 +402,8 @@ remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"
 
 make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
 make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
-   = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
+   = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPatName)
+     ,[(new_var,used_lits)])
   where
      new_var = hash_x
 
@@ -411,7 +414,7 @@ hash_x = mkInternalName unboundKey {- doesn't matter much -}
 
 make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
 make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
-  = takeList (tail pats) (repeat nlWildPat)
+  = takeList (tail pats) (repeat nlWildPatName)
 
 compare_cons :: Pat Id -> Pat Id -> Bool
 compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })
@@ -594,10 +597,14 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
      | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
    where q  = unLoc lq
 
-make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints)
-      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints)
-      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)            : rest_pats, constraints)
-      | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)
+make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats})
+         (ps, constraints)
+      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) [])
+                                : rest_pats, constraints)
+      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)
+                                : rest_pats, constraints)
+      | otherwise        = (nlConPatName name pats_con
+                                : rest_pats, constraints)
     where
         name                  = getName id
         (pats_con, rest_pats) = splitAtList pats ps
@@ -612,11 +619,12 @@ make_con _ _ = panic "Check.make_con: Not ConPatOut"
 --   representation
 
 make_whole_con :: DataCon -> WarningPat
-make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
-                   | otherwise      = nlConPat name pats
+make_whole_con con | isInfixCon con = nlInfixConPat name
+                                           nlWildPatName nlWildPatName
+                   | otherwise      = nlConPatName name pats
                 where
                   name   = getName con
-                  pats   = [nlWildPat | _ <- dataConOrigArgTys con]
+                  pats   = [nlWildPatName | _ <- dataConOrigArgTys con]
 \end{code}
 
 ------------------------------------------------------------------------
@@ -745,7 +753,7 @@ tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id
 tidy_con _   (PrefixCon ps)   = PrefixCon (map tidy_lpat ps)
 tidy_con _   (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]
 tidy_con con (RecCon (HsRecFields fs _))
-  | null fs   = PrefixCon (replicate arity nlWildPat)
+  | null fs   = PrefixCon (replicate arity nlWildPatId)
                 -- Special case for null patterns; maybe not a record at all
   | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
   where
@@ -755,7 +763,7 @@ tidy_con con (RecCon (HsRecFields fs _))
 
      -- pad out all the missing fields with WildPats.
     field_pats = case con of
-        RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc)
+        RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
         PatSynCon{}    -> panic "Check.tidy_con: pattern synonym with record syntax"
     all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
                      field_pats fs
index 2a2d733..7b18b2e 100644 (file)
@@ -676,7 +676,8 @@ makes all list literals be generated via the simple route.
 
 
 \begin{code}
-dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr
+dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
+               -> DsM CoreExpr
 -- See Note [Desugaring explicit lists]
 dsExplicitList elt_ty Nothing xs
   = do { dflags <- getDynFlags
index 31220e4..a0be3d9 100644 (file)
@@ -280,6 +280,7 @@ Library
         HsExpr
         HsImpExp
         HsLit
+        PlaceHolder
         HsPat
         HsSyn
         HsTypes
index d23d1fe..05c935f 100644 (file)
@@ -538,6 +538,7 @@ compiler_stage2_dll0_MODULES = \
        HsExpr \
        HsImpExp \
        HsLit \
+       PlaceHolder \
        HsPat \
        HsSyn \
        HsTypes \
index d722a40..7b841d5 100644 (file)
@@ -140,7 +140,7 @@ cvtDec (TH.ValD pat body ds)
         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
         ; returnL $ Hs.ValD $
           PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
-                  , pat_rhs_ty = void, bind_fvs = placeHolderNames
+                  , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
                   , pat_ticks = (Nothing,[]) } }
 
 cvtDec (TH.FunD nm cls)
@@ -181,7 +181,8 @@ cvtDec (DataD ctxt tc tvs constrs derivs)
                                 , dd_kindSig = Nothing
                                 , dd_cons = cons', dd_derivs = derivs' }
         ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
-                                    , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
+                                    , tcdDataDefn = defn
+                                    , tcdFVs = placeHolderNames }) }
 
 cvtDec (NewtypeD ctxt tc tvs constr derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
@@ -192,7 +193,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
                                 , dd_kindSig = Nothing
                                 , dd_cons = [con'], dd_derivs = derivs' }
         ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
-                                    , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
+                                    , tcdDataDefn = defn
+                                    , tcdFVs = placeHolderNames }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
@@ -248,7 +250,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
 
        ; returnL $ InstD $ DataFamInstD
            { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+                                         , dfid_defn = defn
+                                         , dfid_fvs = placeHolderNames } }}
 
 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
@@ -260,7 +263,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnL $ InstD $ DataFamInstD
            { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+                                         , dfid_defn = defn
+                                         , dfid_fvs = placeHolderNames } }}
 
 cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
@@ -327,7 +331,7 @@ cvt_tycl_hdr cxt tc tvs
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
                -> CvtM ( LHsContext RdrName
                        , Located RdrName
-                       , HsWithBndrs [LHsType RdrName])
+                       , HsWithBndrs RdrName [LHsType RdrName])
 cvt_tyinst_hdr cxt tc tys
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
@@ -596,7 +600,9 @@ cvtl e = wrapL (cvt e)
     cvt (ListE xs)
       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
              -- Note [Converting strings]
-      | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void Nothing xs' }
+      | otherwise       = do { xs' <- mapM cvtl xs
+                             ; return $ ExplicitList placeHolderType Nothing xs'
+                             }
 
     -- Infix expressions
     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
@@ -734,7 +740,7 @@ cvtHsDo do_or_lc stmts
                     L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
                     _ -> failWith (bad_last last')
 
-        ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
+        ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
   where
     bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
                          , nest 2 $ Outputable.ppr stmt
@@ -850,13 +856,16 @@ cvtp (ParensP p)       = do { p' <- cvtPat p; return $ ParPat p' }
 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
-cvtp TH.WildP          = return $ WildPat void
+cvtp TH.WildP          = return $ WildPat placeHolderType
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
-                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
-cvtp (ListP ps)        = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing }
+                            ; return $ ConPatIn c'
+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }
+cvtp (ListP ps)        = do { ps' <- cvtPats ps
+                            ; return $ ListPat ps' placeHolderType Nothing }
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
                             ; return $ SigPatIn p' (mkHsWithBndrs t') }
-cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
+                            ; return $ ViewPat e' p' placeHolderType }
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 cvtPatFld (s,p)
@@ -1032,9 +1041,6 @@ overloadedLit (IntegerL  _) = True
 overloadedLit (RationalL _) = True
 overloadedLit _             = False
 
-void :: Type.Type
-void = placeHolderType
-
 cvtFractionalLit :: Rational -> FractionalLit
 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
 
index 04a7222..e0176a5 100644 (file)
@@ -8,6 +8,11 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
 
 \begin{code}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
 
 module HsBinds where
 
@@ -16,7 +21,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
 
-import HsLit
+import PlaceHolder ( PostTc,PostRn,DataId )
 import HsTypes
 import PprCore ()
 import CoreSyn
@@ -60,11 +65,13 @@ type HsLocalBinds id = HsLocalBindsLR id id
 
 -- | Bindings in a 'let' expression
 -- or a 'where' clause
-data HsLocalBindsLR idL idR    
+data HsLocalBindsLR idL idR
   = HsValBinds (HsValBindsLR idL idR)
   | HsIPBinds  (HsIPBinds idR)
   | EmptyLocalBinds
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId idL, DataId idR)
+  => Data (HsLocalBindsLR idL idR)
 
 type HsValBinds id = HsValBindsLR id id
 
@@ -83,7 +90,9 @@ data HsValBindsLR idL idR
   | ValBindsOut            
         [(RecFlag, LHsBinds idL)]       
         [LSig Name]
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId idL, DataId idR)
+  => Data (HsValBindsLR idL idR)
 
 type LHsBind  id = LHsBindLR  id id
 type LHsBinds id = LHsBindsLR id id
@@ -124,7 +133,8 @@ data HsBindLR idL idR
                                 -- type         Int -> forall a'. a' -> a'
                                 -- Notice that the coercion captures the free a'.
 
-        bind_fvs :: NameSet,    -- ^ After the renamer, this contains the locally-bound
+        bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
+                                --  the locally-bound
                                 -- free variables of this defn.
                                 -- See Note [Bind free vars]
 
@@ -134,11 +144,11 @@ data HsBindLR idL idR
 
   -- | The pattern is never a simple variable;
   -- That case is done by FunBind
-  | PatBind {   
+  | PatBind {
         pat_lhs    :: LPat idL,
         pat_rhs    :: GRHSs idR (LHsExpr idR),
-        pat_rhs_ty :: PostTcType,       -- ^ Type of the GRHSs
-        bind_fvs   :: NameSet,          -- ^ See Note [Bind free vars]
+        pat_rhs_ty :: PostTc idR Type,      -- ^ Type of the GRHSs
+        bind_fvs   :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
         pat_ticks  :: (Maybe (Tickish Id), [Maybe (Tickish Id)])
                -- ^ Tick to put on the rhs, if any, and ticks to put on
                -- the bound variables.
@@ -168,7 +178,10 @@ data HsBindLR idL idR
 
   | PatSynBind (PatSynBind idL idR)
 
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId idL, DataId idR)
+  => Data (HsBindLR idL idR)
+
         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
         --
         -- Creates bindings for (polymorphic, overloaded) poly_f
@@ -190,16 +203,15 @@ data ABExport id
   } deriving (Data, Typeable)
 
 data PatSynBind idL idR
-  = PSB { psb_id   :: Located idL,                   -- ^ Name of the pattern synonym
-          psb_fvs  :: NameSet,                       -- ^ See Note [Bind free vars]
+  = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym
+          psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
           psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
           psb_def  :: LPat idR,                      -- ^ Right-hand side
           psb_dir  :: HsPatSynDir idR                -- ^ Directionality
-  } deriving (Data, Typeable)
+  } deriving (Typeable)
+deriving instance (DataId idL, DataId idR )
+  => Data (PatSynBind idL idR)
 
--- | Used for the NameSet in FunBind and PatBind prior to the renamer
-placeHolderNames :: NameSet
-placeHolderNames = panic "placeHolderNames"
 \end{code}
 
 Note [AbsBinds]
@@ -500,7 +512,8 @@ data HsIPBinds id
         [LIPBind id]
         TcEvBinds       -- Only in typechecker output; binds
                         -- uses of the implicit parameters
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsIPBinds id)
 
 isEmptyIPBinds :: HsIPBinds id -> Bool
 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
@@ -514,7 +527,8 @@ that way until after type-checking when they are replaced with
 evidene for the implicit parameter. -}
 data IPBind id
   = IPBind (Either HsIPName id) (LHsExpr id)
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (IPBind name)
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
@@ -543,7 +557,7 @@ serves for both.
 type LSig name = Located (Sig name)
 
 -- | Signatures and pragmas
-data Sig name   
+data Sig name
   =   -- | An ordinary type signature
       -- @f :: Num a => a -> a@
     TypeSig [Located name] (LHsType name)
@@ -605,7 +619,8 @@ data Sig name
         -- > {-# MINIMAL a | (b, c | (d | e)) #-}
   | MinimalSig (BooleanFormula (Located name))
 
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (Sig name)
 
 
 type LFixitySig name = Located (FixitySig name)
@@ -795,5 +810,6 @@ data HsPatSynDir id
   = Unidirectional
   | ImplicitBidirectional
   | ExplicitBidirectional (MatchGroup id (LHsExpr id))
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsPatSynDir id)
 \end{code}
index 9680c89..f584372 100644 (file)
@@ -6,6 +6,11 @@
 \begin{code}
 {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
              DeriveTraversable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
 
 -- | Abstract syntax of global declarations.
 --
@@ -76,11 +81,12 @@ import HsPat
 import HsTypes
 import HsDoc
 import TyCon
-import NameSet
 import Name
 import BasicTypes
 import Coercion
 import ForeignCall
+import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId )
+import NameSet
 
 -- others:
 import InstEnv
@@ -91,7 +97,7 @@ import SrcLoc
 import FastString
 
 import Bag
-import Data.Data        hiding (TyCon)
+import Data.Data        hiding (TyCon,Fixity)
 import Data.Foldable (Foldable)
 import Data.Traversable
 import Data.Maybe
@@ -123,7 +129,8 @@ data HsDecl id
   | DocD        (DocDecl)
   | QuasiQuoteD (HsQuasiQuote id)
   | RoleAnnotD  (RoleAnnotDecl id)
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsDecl id)
 
 
 -- NB: all top-level fixity decls are contained EITHER
@@ -169,7 +176,8 @@ data HsGroup id
         hs_vects  :: [LVectDecl id],
 
         hs_docs   :: [LDocDecl]
-  } deriving (Data, Typeable)
+  } deriving (Typeable)
+deriving instance (DataId id) => Data (HsGroup id)
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
@@ -284,12 +292,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where
           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
 
 type LSpliceDecl name = Located (SpliceDecl name)
-data SpliceDecl id 
+data SpliceDecl id
   = SpliceDecl                  -- Top level splice
         (Located (HsSplice id))
         HsExplicitFlag          -- Explicit <=> $(f x y)
                                 -- Implicit <=> f x y,  i.e. a naked top level expression
-    deriving (Data, Typeable)
+    deriving (Typeable)
+deriving instance (DataId id) => Data (SpliceDecl id)
 
 instance OutputableBndr name => Outputable (SpliceDecl name) where
    ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
@@ -453,7 +462,7 @@ data TyClDecl name
             , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
             , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
-            , tcdFVs    :: NameSet }
+            , tcdFVs    :: PostRn name NameSet }
 
   | -- | @data@ declaration
     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
@@ -465,7 +474,7 @@ data TyClDecl name
                                                   -- Here the type decl for 'f' includes 'a' 
                                                   -- in its tcdTyVars
              , tcdDataDefn :: HsDataDefn name
-             , tcdFVs      :: NameSet }
+             , tcdFVs      :: PostRn name NameSet }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
@@ -476,10 +485,11 @@ data TyClDecl name
                 tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
                 tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
-                tcdFVs     :: NameSet
+                tcdFVs     :: PostRn name NameSet
     }
-    
-  deriving (Data, Typeable)
+
+  deriving (Typeable)
+deriving instance (DataId id) => Data (TyClDecl id)
 
  -- This is used in TcTyClsDecls to represent
  -- strongly connected components of decls
@@ -489,7 +499,8 @@ data TyClDecl name
 data TyClGroup name
   = TyClGroup { group_tyclds :: [LTyClDecl name]
               , group_roles  :: [LRoleAnnotDecl name] }
-    deriving (Data, Typeable)
+    deriving (Typeable)
+deriving instance (DataId id) => Data (TyClGroup id)
 
 tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name]
 tyClGroupConcat = concatMap group_tyclds
@@ -503,7 +514,8 @@ data FamilyDecl name = FamilyDecl
   , fdLName   :: Located name               -- type constructor
   , fdTyVars  :: LHsTyVarBndrs name         -- type variables
   , fdKindSig :: Maybe (LHsKind name) }     -- result kind
-  deriving( Data, Typeable )
+  deriving( Typeable )
+deriving instance (DataId id) => Data (FamilyDecl id)
 
 data FamilyInfo name
   = DataFamily
@@ -511,7 +523,8 @@ data FamilyInfo name
      -- this list might be empty, if we're in an hs-boot file and the user
      -- said "type family Foo x where .."
   | ClosedTypeFamily [LTyFamInstEqn name]
-  deriving( Data, Typeable )
+  deriving( Typeable )
+deriving instance (DataId name) => Data (FamilyInfo name)
 
 \end{code}
 
@@ -789,7 +802,8 @@ data HsDataDefn name   -- The payload of a data type defn
                      -- Typically the foralls and ty args are empty, but they
                      -- are non-empty for the newtype-deriving case
     }
-    deriving( Data, Typeable )
+    deriving( Typeable )
+deriving instance (DataId id) => Data (HsDataDefn id)
 
 data NewOrData
   = NewType                     -- ^ @newtype Blah ...@
@@ -842,12 +856,13 @@ data ConDecl name
     , con_doc       :: Maybe LHsDocString
         -- ^ A possible Haddock comment.
 
-    , con_old_rec :: Bool   
+    , con_old_rec :: Bool
         -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
         --                             GADT-style record decl   C { blah } :: T a b
         -- Remove this when we no longer parse this stuff, and hence do not
         -- need to report decprecated use
-    } deriving (Data, Typeable)
+    } deriving (Typeable)
+deriving instance (DataId name) => Data (ConDecl name)
 
 type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
 
@@ -964,7 +979,7 @@ It is parameterised over its tfe_pats field:
 type LTyFamInstEqn  name = Located (TyFamInstEqn  name)
 type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
 
-type HsTyPats name = HsWithBndrs [LHsType name]
+type HsTyPats name = HsWithBndrs name [LHsType name]
             -- ^ Type patterns (with kind and type bndrs)
             -- See Note [Family instance declaration binders]
 
@@ -979,14 +994,16 @@ data TyFamEqn name pats
        { tfe_tycon :: Located name
        , tfe_pats  :: pats
        , tfe_rhs   :: LHsType name }
-  deriving( Typeable, Data )
+  deriving( Typeable )
+deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats)
 
 type LTyFamInstDecl name = Located (TyFamInstDecl name)
 data TyFamInstDecl name
   = TyFamInstDecl
        { tfid_eqn  :: LTyFamInstEqn name
-       , tfid_fvs  :: NameSet }
-  deriving( Typeable, Data )
+       , tfid_fvs  :: PostRn name NameSet }
+  deriving( Typeable )
+deriving instance (DataId name) => Data (TyFamInstDecl name)
 
 ----------------- Data family instances -------------
 
@@ -996,8 +1013,10 @@ data DataFamInstDecl name
        { dfid_tycon :: Located name
        , dfid_pats  :: HsTyPats name      -- LHS
        , dfid_defn  :: HsDataDefn  name   -- RHS
-       , dfid_fvs   :: NameSet }          -- Rree vars for dependency analysis
-  deriving( Typeable, Data )
+       , dfid_fvs   :: PostRn name NameSet } -- Rree vars for
+                                               -- dependency analysis
+  deriving( Typeable )
+deriving instance (DataId name) => Data (DataFamInstDecl name)
 
 
 ----------------- Class instances -------------
@@ -1014,7 +1033,8 @@ data ClsInstDecl name
       , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
       , cid_overlap_mode :: Maybe OverlapMode
       }
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (ClsInstDecl id)
 
 
 ----------------- Instances of all kinds -------------
@@ -1027,7 +1047,8 @@ data InstDecl name  -- Both class and family instances
       { dfid_inst :: DataFamInstDecl name }
   | TyFamInstD              -- type family instance
       { tfid_inst :: TyFamInstDecl name }
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (InstDecl id)
 \end{code}
 
 Note [Family instance declaration binders]
@@ -1148,7 +1169,8 @@ type LDerivDecl name = Located (DerivDecl name)
 data DerivDecl name = DerivDecl { deriv_type :: LHsType name
                                 , deriv_overlap_mode :: Maybe OverlapMode
                                 }
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (DerivDecl name)
 
 instance (OutputableBndr name) => Outputable (DerivDecl name) where
     ppr (DerivDecl ty o)
@@ -1170,7 +1192,8 @@ type LDefaultDecl name = Located (DefaultDecl name)
 
 data DefaultDecl name
   = DefaultDecl [LHsType name]
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (DefaultDecl name)
 
 instance (OutputableBndr name)
               => Outputable (DefaultDecl name) where
@@ -1198,13 +1221,14 @@ type LForeignDecl name = Located (ForeignDecl name)
 data ForeignDecl name
   = ForeignImport (Located name) -- defines this name
                   (LHsType name) -- sig_ty
-                  Coercion       -- rep_ty ~ sig_ty
+                  (PostTc name Coercion) -- rep_ty ~ sig_ty
                   ForeignImport
   | ForeignExport (Located name) -- uses this name
                   (LHsType name) -- sig_ty
-                  Coercion       -- sig_ty ~ rep_ty
+                  (PostTc name Coercion)  -- sig_ty ~ rep_ty
                   ForeignExport
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (ForeignDecl name)
 {-
     In both ForeignImport and ForeignExport:
         sig_ty is the type given in the Haskell code
@@ -1214,13 +1238,11 @@ data ForeignDecl name
     such as Int and IO that we know how to make foreign calls with.
 -}
 
-noForeignImportCoercionYet :: Coercion
-noForeignImportCoercionYet
-    = panic "ForeignImport coercion evaluated before typechecking"
+noForeignImportCoercionYet :: PlaceHolder
+noForeignImportCoercionYet = PlaceHolder
 
-noForeignExportCoercionYet :: Coercion
-noForeignExportCoercionYet
-    = panic "ForeignExport coercion evaluated before typechecking"
+noForeignExportCoercionYet :: PlaceHolder
+noForeignExportCoercionYet = PlaceHolder
 
 -- Specification Of an imported external entity in dependence on the calling
 -- convention 
@@ -1311,17 +1333,19 @@ data RuleDecl name
         Activation
         [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
         (Located (HsExpr name)) -- LHS
-        NameSet                 -- Free-vars from the LHS
+        (PostRn name NameSet)        -- Free-vars from the LHS
         (Located (HsExpr name)) -- RHS
-        NameSet                 -- Free-vars from the RHS
-  deriving (Data, Typeable)
+        (PostRn name NameSet)        -- Free-vars from the RHS
+  deriving (Typeable)
+deriving instance (DataId name) => Data (RuleDecl name)
 
 data RuleBndr name
   = RuleBndr (Located name)
-  | RuleBndrSig (Located name) (HsWithBndrs (LHsType name))
-  deriving (Data, Typeable)
+  | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name))
+  deriving (Typeable)
+deriving instance (DataId name) => Data (RuleBndr name)
 
-collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)]
+collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
@@ -1379,7 +1403,8 @@ data VectDecl name
       (LHsType name)
   | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
       ClsInst
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (VectDecl name)
 
 lvectDeclName :: NamedThing name => LVectDecl name -> Name
 lvectDeclName (L _ (HsVect         (L _ name) _))   = getName name
@@ -1487,10 +1512,11 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
 type LAnnDecl name = Located (AnnDecl name)
 
 data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (AnnDecl name)
 
 instance (OutputableBndr name) => Outputable (AnnDecl name) where
-    ppr (HsAnnotation provenance expr) 
+    ppr (HsAnnotation provenance expr)
       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
 
 
index 69b6df6..c61e0c7 100644 (file)
@@ -4,6 +4,11 @@
 %
 \begin{code}
 {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
 
 -- | Abstract Haskell syntax for expressions.
 module HsExpr where
@@ -14,6 +19,7 @@ module HsExpr where
 import HsDecls
 import HsPat
 import HsLit
+import PlaceHolder ( PostTc,PostRn,DataId )
 import HsTypes
 import HsBinds
 
@@ -30,12 +36,12 @@ import Util
 import StaticFlags( opt_PprStyle_Debug )
 import Outputable
 import FastString
+import Type
 
 -- libraries:
 import Data.Data hiding (Fixity)
 \end{code}
 
-
 %************************************************************************
 %*                                                                      *
 \subsection{Expressions proper}
@@ -127,7 +133,7 @@ data HsExpr id
 
   | HsLam     (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match
 
-  | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
+  | HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
 
   | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application
 
@@ -139,7 +145,7 @@ data HsExpr id
 
   | OpApp       (LHsExpr id)    -- left operand
                 (LHsExpr id)    -- operator
-                Fixity          -- Renamer adds fixity; bottom until then
+                (PostRn id Fixity) -- Renamer adds fixity; bottom until then
                 (LHsExpr id)    -- right operand
 
   -- | Negation operator. Contains the negated expression and the name
@@ -170,7 +176,7 @@ data HsExpr id
                 (LHsExpr id)    --  else part
 
   -- | Multi-way if
-  | HsMultiIf   PostTcType [LGRHS id (LHsExpr id)] 
+  | HsMultiIf   (PostTc id Type) [LGRHS id (LHsExpr id)]
 
   -- | let(rec)
   | HsLet       (HsLocalBinds id) 
@@ -180,17 +186,17 @@ data HsExpr id
                                      -- because in this context we never use
                                      -- the PatGuard or ParStmt variant
                 [ExprLStmt id]       -- "do":one or more stmts
-                PostTcType           -- Type of the whole expression
+                (PostTc id Type)     -- Type of the whole expression
 
   -- | Syntactic list: [a,b,c,...]
-  | ExplicitList                        
-                PostTcType              -- Gives type of components of list
+  | ExplicitList
+                (PostTc id Type)        -- Gives type of components of list
                 (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
                 [LHsExpr id]
 
   -- | Syntactic parallel array: [:e1, ..., en:]
-  | ExplicitPArr                
-                PostTcType      -- type of elements of the parallel array
+  | ExplicitPArr
+                (PostTc id Type)   -- type of elements of the parallel array
                 [LHsExpr id]
 
   -- | Record construction
@@ -207,8 +213,8 @@ data HsExpr id
                 [DataCon]          -- Filled in by the type checker to the
                                    -- _non-empty_ list of DataCons that have
                                    -- all the upd'd fields
-                [PostTcType]       -- Argument types of *input* record type
-                [PostTcType]       --              and  *output* record type
+                [PostTc id Type]   -- Argument types of *input* record type
+                [PostTc id Type]   --              and  *output* record type
   -- For a type family, the arg types are of the *instance* tycon,
   -- not the family tycon
 
@@ -274,22 +280,22 @@ data HsExpr id
   -- The following are commands, not expressions proper
   -- They are only used in the parsing stage and are removed
   --    immediately in parser.RdrHsSyn.checkCommand
-  | HsArrApp            -- Arrow tail, or arrow application (f -< arg)
-        (LHsExpr id)    -- arrow expression, f
-        (LHsExpr id)    -- input expression, arg
-        PostTcType      -- type of the arrow expressions f,
-                        -- of the form a t t', where arg :: t
-        HsArrAppType    -- higher-order (-<<) or first-order (-<)
-        Bool            -- True => right-to-left (f -< arg)
-                        -- False => left-to-right (arg >- f)
-
-  | HsArrForm           -- Command formation,  (| e cmd1 .. cmdn |)
-        (LHsExpr id)    -- the operator
-                        -- after type-checking, a type abstraction to be
-                        -- applied to the type of the local environment tuple
-        (Maybe Fixity)  -- fixity (filled in by the renamer), for forms that
-                        -- were converted from OpApp's by the renamer
-        [LHsCmdTop id]  -- argument commands
+  | HsArrApp             -- Arrow tail, or arrow application (f -< arg)
+        (LHsExpr id)     -- arrow expression, f
+        (LHsExpr id)     -- input expression, arg
+        (PostTc id Type) -- type of the arrow expressions f,
+                         -- of the form a t t', where arg :: t
+        HsArrAppType     -- higher-order (-<<) or first-order (-<)
+        Bool             -- True => right-to-left (f -< arg)
+                         -- False => left-to-right (arg >- f)
+
+  | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)
+        (LHsExpr id)     -- the operator
+                         -- after type-checking, a type abstraction to be
+                         -- applied to the type of the local environment tuple
+        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that
+                         -- were converted from OpApp's by the renamer
+        [LHsCmdTop id]   -- argument commands
 
   ---------------------------------------
   -- Haskell program coverage (Hpc) Support
@@ -329,15 +335,17 @@ data HsExpr id
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
   |  HsUnboundVar RdrName
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsExpr id)
 
 -- | HsTupArg is used for tuple sections
 --  (,a,) is represented by  ExplicitTuple [Mising ty1, Present a, Missing ty3]
 --  Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
 data HsTupArg id
-  = Present (LHsExpr id)        -- ^ The argument
-  | Missing PostTcType          -- ^ The argument is missing, but this is its type
-  deriving (Data, Typeable)
+  = Present (LHsExpr id)     -- ^ The argument
+  | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsTupArg id)
 
 tupArgPresent :: HsTupArg id -> Bool
 tupArgPresent (Present {}) = True
@@ -716,22 +724,22 @@ We re-use HsExpr to represent these.
 type LHsCmd id = Located (HsCmd id)
 
 data HsCmd id
-  = HsCmdArrApp         -- Arrow tail, or arrow application (f -< arg)
-        (LHsExpr id)    -- arrow expression, f
-        (LHsExpr id)    -- input expression, arg
-        PostTcType      -- type of the arrow expressions f,
-                        -- of the form a t t', where arg :: t
-        HsArrAppType    -- higher-order (-<<) or first-order (-<)
-        Bool            -- True => right-to-left (f -< arg)
-                        -- False => left-to-right (arg >- f)
-
-  | HsCmdArrForm        -- Command formation,  (| e cmd1 .. cmdn |)
-        (LHsExpr id)    -- the operator
-                        -- after type-checking, a type abstraction to be
-                        -- applied to the type of the local environment tuple
-        (Maybe Fixity)  -- fixity (filled in by the renamer), for forms that
-                        -- were converted from OpApp's by the renamer
-        [LHsCmdTop id]  -- argument commands
+  = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)
+        (LHsExpr id)     -- arrow expression, f
+        (LHsExpr id)     -- input expression, arg
+        (PostTc id Type) -- type of the arrow expressions f,
+                         -- of the form a t t', where arg :: t
+        HsArrAppType     -- higher-order (-<<) or first-order (-<)
+        Bool             -- True => right-to-left (f -< arg)
+                         -- False => left-to-right (arg >- f)
+
+  | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
+        (LHsExpr id)     -- the operator
+                         -- after type-checking, a type abstraction to be
+                         -- applied to the type of the local environment tuple
+        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that
+                         -- were converted from OpApp's by the renamer
+        [LHsCmdTop id]   -- argument commands
 
   | HsCmdApp    (LHsCmd id)
                 (LHsExpr id)
@@ -752,14 +760,14 @@ data HsCmd id
                 (LHsCmd  id)
 
   | HsCmdDo     [CmdLStmt id]
-                PostTcType                      -- Type of the whole expression
+                (PostTc id Type)                -- Type of the whole expression
 
   | HsCmdCast   TcCoercion     -- A simpler version of HsWrap in HsExpr
                 (HsCmd id)     -- If   cmd :: arg1 --> res
                                --       co :: arg1 ~ arg2
                                -- Then (HsCmdCast co cmd) :: arg2 --> res
-                
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsCmd id)
 
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
   deriving (Data, Typeable)
@@ -775,10 +783,11 @@ type LHsCmdTop id = Located (HsCmdTop id)
 
 data HsCmdTop id
   = HsCmdTop (LHsCmd id)
-             PostTcType          -- Nested tuple of inputs on the command's stack
-             PostTcType          -- return type of the command
+             (PostTc id Type)   -- Nested tuple of inputs on the command's stack
+             (PostTc id Type)   -- return type of the command
              (CmdSyntaxTable id) -- See Note [CmdSyntaxTable]
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsCmdTop id)
 \end{code}
 
 
@@ -906,13 +915,14 @@ patterns in each equation.
 \begin{code}
 data MatchGroup id body
   = MG { mg_alts    :: [LMatch id body]  -- The alternatives
-       , mg_arg_tys :: [PostTcType]      -- Types of the arguments, t1..tn
-       , mg_res_ty  :: PostTcType        -- Type of the result, tr 
+       , mg_arg_tys :: [PostTc id Type]  -- Types of the arguments, t1..tn
+       , mg_res_ty  :: PostTc id Type    -- Type of the result, tr
        , mg_origin  :: Origin }
      -- The type is the type of the entire group
      --      t1 -> ... -> tn -> tr
      -- where there are n patterns
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (Data body,DataId id) => Data (MatchGroup id body)
 
 type LMatch id body = Located (Match id body)
 
@@ -922,7 +932,8 @@ data Match id body
         (Maybe (LHsType id))    -- A type signature for the result of the match
                                 -- Nothing after typechecking
         (GRHSs id body)
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (Data body,DataId id) => Data (Match id body)
 
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
@@ -942,14 +953,16 @@ data GRHSs id body
   = GRHSs {
       grhssGRHSs :: [LGRHS id body],       -- ^ Guarded RHSs
       grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
-    } deriving (Data, Typeable)
+    } deriving (Typeable)
+deriving instance (Data body,DataId id) => Data (GRHSs id body)
 
 type LGRHS id body = Located (GRHS id body)
 
 -- | Guarded Right Hand Side.
 data GRHS id body = GRHS [GuardLStmt id] -- Guards
                          body            -- Right hand side
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (Data body,DataId id) => Data (GRHS id body)
 \end{code}
 
 We know the list must have at least one @Match@ in it.
@@ -1066,11 +1079,11 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
 
-  | BodyStmt body             -- See Note [BodyStmt]
-             (SyntaxExpr idR) -- The (>>) operator
-             (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
-                              -- See notes [Monad Comprehensions]
-             PostTcType       -- Element type of the RHS (used for arrows)
+  | BodyStmt body              -- See Note [BodyStmt]
+             (SyntaxExpr idR)  -- The (>>) operator
+             (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp
+                               -- See notes [Monad Comprehensions]
+             (PostTc idR Type) -- Element type of the RHS (used for arrows)
 
   | LetStmt  (HsLocalBindsLR idL idR)
 
@@ -1131,11 +1144,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
                                      -- the returned thing has to be *monomorphic*,
                                      -- so they may be type applications
 
-      , recS_ret_ty :: PostTcType    -- The type of of do { stmts; return (a,b,c) }
-                                     -- With rebindable syntax the type might not
-                                     -- be quite as simple as (m (tya, tyb, tyc)).
+      , recS_ret_ty :: PostTc idR Type -- The type of
+                                       -- do { stmts; return (a,b,c) }
+                                   -- With rebindable syntax the type might not
+                                   -- be quite as simple as (m (tya, tyb, tyc)).
       }
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (Data body, DataId idL, DataId idR)
+  => Data (StmtLR idL idR body)
 
 data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function
   = ThenForm     -- then f               or    then f by e             (depending on trS_by)
@@ -1147,7 +1163,8 @@ data ParStmtBlock idL idR
         [ExprLStmt idL]
         [idR]              -- The variables to be returned
         (SyntaxExpr idR)   -- The return operator
-  deriving( Data, Typeable )
+  deriving( Typeable )
+deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
 \end{code}
 
 Note [The type of bind in Stmts]
@@ -1373,7 +1390,8 @@ pprQuals quals = interpp'SP quals
 data HsSplice id  = HsSplice            --  $z  or $(f 4)
                         id              -- The id is just a unique name to
                         (LHsExpr id)    -- identify this splice point
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsSplice id)
 
 instance OutputableBndr id => Outputable (HsSplice id) where
   ppr (HsSplice n e) = angleBrackets (ppr n <> comma <+> ppr e)
@@ -1406,7 +1424,8 @@ data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | VarBr Bool id        -- True: 'x, False: ''T
                                          -- (The Bool flag is used only in pprHsBracket)
                   | TExpBr (LHsExpr id)  -- [||  expr  ||]
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsBracket id)
 
 isTypedBracket :: HsBracket id -> Bool
 isTypedBracket (TExpBr {}) = True
@@ -1457,7 +1476,8 @@ data ArithSeqInfo id
   | FromThenTo      (LHsExpr id)
                     (LHsExpr id)
                     (LHsExpr id)
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (ArithSeqInfo id)
 \end{code}
 
 \begin{code}
index 027fd7e..387a83e 100644 (file)
@@ -1,13 +1,28 @@
 \begin{code}
 {-# LANGUAGE CPP, KindSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
+#if __GLASGOW_HASKELL__ > 706
+{-# LANGUAGE RoleAnnotations #-}
+#endif
+
 module HsExpr where
 
 import SrcLoc     ( Located )
 import Outputable ( SDoc, OutputableBndr, Outputable )
 import {-# SOURCE #-} HsPat  ( LPat )
+import PlaceHolder ( DataId )
+import Data.Data hiding ( Fixity )
 
-import Data.Data
-
+#if __GLASGOW_HASKELL__ > 706
+type role HsExpr nominal
+type role HsCmd nominal
+type role MatchGroup nominal representational
+type role GRHSs nominal representational
+type role HsSplice nominal
+#endif
 data HsExpr (i :: *)
 data HsCmd  (i :: *)
 data HsSplice (i :: *)
@@ -27,11 +42,11 @@ instance Typeable2 MatchGroup
 instance Typeable2 GRHSs
 #endif
 
-instance Data i => Data (HsSplice i)
-instance Data i => Data (HsExpr i)
-instance Data i => Data (HsCmd i)
-instance (Data i, Data body) => Data (MatchGroup i body)
-instance (Data i, Data body) => Data (GRHSs i body)
+instance (DataId id) => Data (HsSplice id)
+instance (DataId id) => Data (HsExpr id)
+instance (DataId id) => Data (HsCmd id)
+instance (Data body,DataId id) => Data (MatchGroup id body)
+instance (Data body,DataId id) => Data (GRHSs id body)
 
 instance OutputableBndr id => Outputable (HsExpr id)
 instance OutputableBndr id => Outputable (HsCmd id)
index a766e40..db6e126 100644 (file)
@@ -6,40 +6,32 @@
 
 \begin{code}
 {-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
+
 module HsLit where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
 import BasicTypes ( FractionalLit(..) )
-import Type     ( Type, Kind )
+import Type       ( Type )
 import Outputable
 import FastString
+import PlaceHolder ( PostTc,PostRn,DataId )
 
 import Data.ByteString (ByteString)
-import Data.Data
+import Data.Data hiding ( Fixity )
 \end{code}
 
 
-%************************************************************************
-%*                                                                      *
-\subsection{Annotating the syntax}
-%*                                                                      *
-%************************************************************************
 
-\begin{code}
-type PostTcKind = Kind
-type PostTcType = Type          -- Used for slots in the abstract syntax
-                                -- where we want to keep slot for a type
-                                -- to be added by the type checker...but
-                                -- before typechecking it's just bogus
-
-placeHolderType :: PostTcType   -- Used before typechecking
-placeHolderType  = panic "Evaluated the place holder for a PostTcType"
 
-placeHolderKind :: PostTcKind   -- Used before typechecking
-placeHolderKind  = panic "Evaluated the place holder for a PostTcKind"
-\end{code}
 
 %************************************************************************
 %*                                                                      *
@@ -50,22 +42,24 @@ placeHolderKind  = panic "Evaluated the place holder for a PostTcKind"
 
 \begin{code}
 data HsLit
-  = HsChar          Char                -- Character
-  | HsCharPrim      Char                -- Unboxed character
-  | HsString        FastString          -- String
-  | HsStringPrim    ByteString          -- Packed bytes
-  | HsInt           Integer             -- Genuinely an Int; arises from TcGenDeriv,
-                                        --      and from TRANSLATION
-  | HsIntPrim       Integer             -- literal Int#
-  | HsWordPrim      Integer             -- literal Word#
-  | HsInt64Prim     Integer             -- literal Int64#
-  | HsWord64Prim    Integer             -- literal Word64#
-  | HsInteger       Integer  Type       -- Genuinely an integer; arises only from TRANSLATION
-                                        --      (overloaded literals are done with HsOverLit)
-  | HsRat           FractionalLit Type  -- Genuinely a rational; arises only from TRANSLATION
-                                        --      (overloaded literals are done with HsOverLit)
-  | HsFloatPrim     FractionalLit       -- Unboxed Float
-  | HsDoublePrim    FractionalLit       -- Unboxed Double
+  = HsChar          Char               -- Character
+  | HsCharPrim      Char               -- Unboxed character
+  | HsString        FastString         -- String
+  | HsStringPrim    ByteString         -- Packed bytes
+  | HsInt           Integer            -- Genuinely an Int; arises from
+                                       --     TcGenDeriv, and from TRANSLATION
+  | HsIntPrim       Integer            -- literal Int#
+  | HsWordPrim      Integer            -- literal Word#
+  | HsInt64Prim     Integer            -- literal Int64#
+  | HsWord64Prim    Integer            -- literal Word64#
+  | HsInteger       Integer  Type      -- Genuinely an integer; arises only from
+                                       --   TRANSLATION (overloaded literals are
+                                       --   done with HsOverLit)
+  | HsRat           FractionalLit Type -- Genuinely a rational; arises only from
+                                       --   TRANSLATION (overloaded literals are
+                                       --   done with HsOverLit)
+  | HsFloatPrim     FractionalLit      -- Unboxed Float
+  | HsDoublePrim    FractionalLit      -- Unboxed Double
   deriving (Data, Typeable)
 
 instance Eq HsLit where
@@ -87,10 +81,11 @@ instance Eq HsLit where
 data HsOverLit id       -- An overloaded literal
   = OverLit {
         ol_val :: OverLitVal,
-        ol_rebindable :: Bool,          -- Note [ol_rebindable]
-        ol_witness :: SyntaxExpr id,    -- Note [Overloaded literal witnesses]
-        ol_type :: PostTcType }
-  deriving (Data, Typeable)
+        ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable]
+        ol_witness :: SyntaxExpr id,     -- Note [Overloaded literal witnesses]
+        ol_type :: PostTc id Type }
+  deriving (Typeable)
+deriving instance (DataId id) => Data (HsOverLit id)
 
 data OverLitVal
   = HsIntegral   !Integer       -- Integer-looking literals;
@@ -98,7 +93,7 @@ data OverLitVal
   | HsIsString   !FastString    -- String-looking literals
   deriving (Data, Typeable)
 
-overLitType :: HsOverLit a -> Type
+overLitType :: HsOverLit a -> PostTc a Type
 overLitType = ol_type
 \end{code}
 
index 4b8fcda..bbd37bc 100644 (file)
@@ -6,6 +6,12 @@
 
 \begin{code}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
 
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
@@ -28,6 +34,7 @@ import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr
 -- friends:
 import HsBinds
 import HsLit
+import PlaceHolder ( PostTc,DataId )
 import HsTypes
 import TcEvidence
 import BasicTypes
@@ -43,7 +50,7 @@ import Type
 import SrcLoc
 import FastString
 -- libraries:
-import Data.Data hiding (TyCon)
+import Data.Data hiding (TyCon,Fixity)
 import Data.Maybe
 \end{code}
 
@@ -56,7 +63,7 @@ type LPat id = Located (Pat id)
 
 data Pat id
   =     ------------ Simple patterns ---------------
-    WildPat     PostTcType              -- Wild card
+    WildPat     (PostTc id Type)        -- Wild card
         -- The sole reason for a type on a WildPat is to
         -- support hsPatType :: Pat Id -> Type
 
@@ -69,17 +76,17 @@ data Pat id
 
         ------------ Lists, tuples, arrays ---------------
   | ListPat     [LPat id]                            -- Syntactic list
-                PostTcType                           -- The type of the elements
-                (Maybe (PostTcType, SyntaxExpr id))  -- For rebindable syntax
+                (PostTc id Type)                     -- The type of the elements
+                (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax
                    -- For OverloadedLists a Just (ty,fn) gives
                    -- overall type of the pattern, and the toList
                    -- function to convert the scrutinee to a list value
 
-  | TuplePat    [LPat id]    -- Tuple sub-patterns
-                Boxity       -- UnitPat is TuplePat []
-                [PostTcType] -- [] before typechecker, filled in afterwards with
-                             -- the types of the tuple components
-        -- You might think that the PostTcType was redundant, because we can 
+  | TuplePat    [LPat id]        -- Tuple sub-patterns
+                Boxity           -- UnitPat is TuplePat []
+                [PostTc id Type] -- [] before typechecker, filled in afterwards
+                                 -- with the types of the tuple components
+        -- You might think that the PostTc id Type was redundant, because we can
         -- get the pattern type by getting the types of the sub-patterns.
         -- But it's essential
         --      data T a where
@@ -96,7 +103,7 @@ data Pat id
         --           will be wrapped in CoPats, no?)
 
   | PArrPat     [LPat id]               -- Syntactic parallel array
-                PostTcType              -- The type of the elements
+                (PostTc id Type)        -- The type of the elements
 
         ------------ Constructor patterns ---------------
   | ConPatIn    (Located id)
@@ -121,7 +128,7 @@ data Pat id
         ------------ View patterns ---------------
   | ViewPat       (LHsExpr id)
                   (LPat id)
-                  PostTcType        -- The overall type of the pattern
+                  (PostTc id Type)  -- The overall type of the pattern
                                     -- (= the argument type of the view function)
                                     -- for hsPatType.
 
@@ -149,8 +156,9 @@ data Pat id
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
 
         ------------ Pattern type signatures ---------------
-  | SigPatIn        (LPat id)                   -- Pattern with a type signature
-                    (HsWithBndrs (LHsType id))  -- Signature can bind both kind and type vars
+  | SigPatIn        (LPat id)                  -- Pattern with a type signature
+                    (HsWithBndrs id (LHsType id)) -- Signature can bind both
+                                                  -- kind and type vars
 
   | SigPatOut       (LPat id)           -- Pattern with a type signature
                     Type
@@ -162,7 +170,8 @@ data Pat id
                 Type                    -- Type of whole pattern, t1
         -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
         -- the scrutinee, followed by a match on 'pat'
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId id) => Data (Pat id)
 \end{code}
 
 HsConDetails is use for patterns/expressions *and* for data type declarations
index 0e7a0e0..cb8cb0a 100644 (file)
@@ -1,12 +1,23 @@
 \begin{code}
 {-# LANGUAGE CPP, KindSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
+#if __GLASGOW_HASKELL__ > 706
+{-# LANGUAGE RoleAnnotations #-}
+#endif
 
 module HsPat where
 import SrcLoc( Located )
 
-import Data.Data
+import Data.Data hiding (Fixity)
 import Outputable
+import PlaceHolder      ( DataId )
 
+#if __GLASGOW_HASKELL__ > 706
+type role Pat nominal
+#endif
 data Pat (i :: *)
 type LPat i = Located (Pat i)
 
@@ -16,6 +27,6 @@ instance Typeable Pat
 instance Typeable1 Pat
 #endif
 
-instance Data i => Data (Pat i)
+instance (DataId id) => Data (Pat id)
 instance (OutputableBndr name) => Outputable (Pat name)
 \end{code}
index 72cbac1..7aecfea 100644 (file)
@@ -10,6 +10,11 @@ therefore, is almost nothing but re-exporting.
 
 \begin{code}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
 
 module HsSyn (
         module HsBinds,
@@ -21,6 +26,7 @@ module HsSyn (
         module HsTypes,
         module HsUtils,
         module HsDoc,
+        module PlaceHolder,
         Fixity,
 
         HsModule(..)
@@ -32,6 +38,7 @@ import HsBinds
 import HsExpr
 import HsImpExp
 import HsLit
+import PlaceHolder
 import HsPat
 import HsTypes
 import BasicTypes       ( Fixity, WarningTxt )
@@ -75,7 +82,8 @@ data HsModule name
         -- ^ reason\/explanation for warning/deprecation of this module
       hsmodHaddockModHeader :: Maybe LHsDocString
         -- ^ Haddock module info and description, unparsed
-   } deriving (Data, Typeable)
+   } deriving (Typeable)
+deriving instance (DataId name) => Data (HsModule name)
 \end{code}
 
 
index 0cf8455..fdd613a 100644 (file)
@@ -7,6 +7,13 @@ HsTypes: Abstract syntax: user-defined types
 
 \begin{code}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
 
 module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
@@ -40,7 +47,7 @@ module HsTypes (
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
 
-import HsLit
+import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
 import Name( Name )
 import RdrName( RdrName )
@@ -54,7 +61,7 @@ import StaticFlags
 import Outputable
 import FastString
 
-import Data.Data
+import Data.Data hiding ( Fixity )
 \end{code}
 
 
@@ -131,17 +138,18 @@ type LHsKind name = Located (HsKind name)
 
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
-data LHsTyVarBndrs name 
+data LHsTyVarBndrs name
   = HsQTvs { hsq_kvs :: [Name]                  -- Kind variables
            , hsq_tvs :: [LHsTyVarBndr name]     -- Type variables
              -- See Note [HsForAllTy tyvar binders]
     }
-  deriving( Data, Typeable )
+  deriving( Typeable )
+deriving instance (DataId name) => Data (LHsTyVarBndrs name)
 
 mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName
 -- Just at RdrName because in the Name variant we should know just
 -- what the kind-variable binders are; and we don't
--- We put an empty list (rather than a panic) for the kind vars so 
+-- We put an empty list (rather than a panic) for the kind vars so
 -- that the pretty printer works ok on them.
 mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
 
@@ -151,16 +159,18 @@ emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
-data HsWithBndrs thing
-  = HsWB { hswb_cts :: thing         -- Main payload (type or list of types)
-         , hswb_kvs :: [Name]        -- Kind vars
-         , hswb_tvs :: [Name]        -- Type vars
-    }                  
-  deriving (Data, Typeable)
+data HsWithBndrs name thing
+  = HsWB { hswb_cts :: thing             -- Main payload (type or list of types)
+         , hswb_kvs :: PostRn name [Name] -- Kind vars
+         , hswb_tvs :: PostRn name [Name] -- Type vars
+    }
+  deriving (Typeable)
+deriving instance (Data name, Data thing, Data (PostRn name [Name]))
+  => Data (HsWithBndrs name thing)
 
-mkHsWithBndrs :: thing -> HsWithBndrs thing
-mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
-                                     , hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
+mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing
+mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder
+                                     , hswb_tvs = PlaceHolder }
 
 
 -- | These names are used early on to store the names of implicit
@@ -186,7 +196,8 @@ data HsTyVarBndr name
   | KindedTyVar
          name
          (LHsKind name)  -- The user-supplied kind signature
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (HsTyVarBndr name)
 
 -- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
 isHsKindedTyVar :: HsTyVarBndr name -> Bool
@@ -239,7 +250,7 @@ data HsType name
   | HsQuasiQuoteTy      (HsQuasiQuote name)
 
   | HsSpliceTy          (HsSplice name) 
-                        PostTcKind
+                        (PostTc name Kind)
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
@@ -249,18 +260,19 @@ data HsType name
   | HsCoreTy Type       -- An escape hatch for tunnelling a *closed* 
                         -- Core Type through HsSyn.  
 
-  | HsExplicitListTy     -- A promoted explicit list
-        PostTcKind       -- See Note [Promoted lists and tuples]
+  | HsExplicitListTy       -- A promoted explicit list
+        (PostTc name Kind) -- See Note [Promoted lists and tuples]
         [LHsType name]   
                          
-  | HsExplicitTupleTy    -- A promoted explicit tuple
-        [PostTcKind]     -- See Note [Promoted lists and tuples]
+  | HsExplicitTupleTy      -- A promoted explicit tuple
+        [PostTc name Kind] -- See Note [Promoted lists and tuples]
         [LHsType name]   
 
   | HsTyLit HsTyLit      -- A promoted numeric literal.
 
   | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (HsType name)
 
 
 data HsTyLit
@@ -380,7 +392,8 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
                    cd_fld_type :: LBangType name, 
                    cd_fld_doc  :: Maybe LHsDocString }
-  deriving (Data, Typeable)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (ConDeclField name)
 
 -----------------------
 -- Combine adjacent for-alls. 
@@ -565,7 +578,7 @@ instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar n)     = ppr n
     ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
 
-instance (Outputable thing) => Outputable (HsWithBndrs thing) where
+instance (Outputable thing) => Outputable (HsWithBndrs name thing) where
     ppr (HsWB { hswb_cts = ty }) = ppr ty
 
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name ->  LHsContext name -> SDoc
index 5d4d22f..4b5bdb4 100644 (file)
@@ -1,4 +1,3 @@
-> {-# LANGUAGE ScopedTypeVariables #-}
 
 %
 % (c) The University of Glasgow, 1992-2006
@@ -8,11 +7,11 @@ Here we collect a variety of helper functions that construct or
 analyse HsSyn.  All these functions deal with generic HsSyn; functions
 which deal with the instantiated versions are located elsewhere:
 
-   Parameterised by    Module
+   Parameterised by     Module
    ----------------     -------------
-   RdrName             parser/RdrHsSyn
-   Name                        rename/RnHsSyn
-   Id                  typecheck/TcHsSyn       
+   RdrName              parser/RdrHsSyn
+   Name                 rename/RnHsSyn
+   Id                   typecheck/TcHsSyn
 
 \begin{code}
 {-# LANGUAGE CPP #-}
@@ -22,18 +21,20 @@ which deal with the instantiated versions are located elsewhere:
 -- detab the module (please do the detabbing in a separate patch). See
 --     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module HsUtils(
   -- Terms
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
-  mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
-  mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
+  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
+  mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
   coToHsWrapper, mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdCast,
 
-  nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
+  nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
   toHsType, toHsKind,
@@ -42,27 +43,28 @@ module HsUtils(
   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind,
 
   -- Literals
-  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, 
+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
 
   -- Patterns
-  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
-  nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, mkParPat,
+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat,
+  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
+  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
 
   -- Types
   mkHsAppTy, userHsTyVarBndrs,
-  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, 
+  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
 
   -- Stmts
   mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
-  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, 
-  emptyRecStmt, mkRecStmt, 
+  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
+  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
 
   -- Template Haskell
   mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice,
   mkHsQuasiQuote, unqualQuasiQuote,
 
   -- Flags
-  noRebindableInfo, 
+  noRebindableInfo,
 
   -- Collecting binders
   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
@@ -71,9 +73,9 @@ module HsUtils(
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
 
-  hsLTyClDeclBinders, hsTyClDeclsBinders, 
+  hsLTyClDeclBinders, hsTyClDeclsBinders,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-  
+
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
   ) where
@@ -84,8 +86,9 @@ import HsDecls
 import HsBinds
 import HsExpr
 import HsPat
-import HsTypes 
+import HsTypes
 import HsLit
+import PlaceHolder
 
 import TcEvidence
 import RdrName
@@ -110,9 +113,9 @@ import Data.List
 
 
 %************************************************************************
-%*                                                                     *
-       Some useful helpers for constructing syntax
-%*                                                                     *
+%*                                                                      *
+        Some useful helpers for constructing syntax
+%*                                                                      *
 %************************************************************************
 
 These functions attempt to construct a not-completely-useless SrcSpan
@@ -124,13 +127,13 @@ mkHsPar :: LHsExpr id -> LHsExpr id
 mkHsPar e = L (getLoc e) (HsPar e)
 
 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
-mkSimpleMatch pats rhs 
+mkSimpleMatch pats rhs
   = L loc $
     Match pats Nothing (unguardedGRHSs rhs)
   where
     loc = case pats of
-               []      -> getLoc rhs
-               (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
+                []      -> getLoc rhs
+                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 
 unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
@@ -138,8 +141,17 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
 unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
 
-mkMatchGroup :: Origin -> [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
-mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType, mg_origin = origin }
+mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
+             -> MatchGroup RdrName (Located (body RdrName))
+mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = []
+                                 , mg_res_ty = placeHolderType
+                                 , mg_origin = origin }
+
+mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
+             -> MatchGroup Name (Located (body Name))
+mkMatchGroupName origin matches = MG { mg_alts = matches, mg_arg_tys = []
+                                     , mg_res_ty = placeHolderType
+                                     , mg_origin = origin }
 
 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
@@ -147,24 +159,25 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 
-mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
+mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
-       where
+        where
           matches = mkMatchGroup Generated [mkSimpleMatch pats body]
 
 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
-mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
+mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
+                                       <.> mkWpLams dicts) expr
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
--- Used for constructing dictionary terms etc, so no locations 
-mkHsConApp data_con tys args 
+-- Used for constructing dictionary terms etc, so no locations
+mkHsConApp data_con tys args
   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
   where
     mk_app f a = noLoc (HsApp f (noLoc a))
 
 mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
-mkSimpleHsAlt pat expr 
+mkSimpleHsAlt pat expr
   = mkSimpleMatch [pat] expr
 
 nlHsTyApp :: name -> [Type] -> LHsExpr name
@@ -186,29 +199,33 @@ mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
 
-mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
-mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id
-mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
-mkHsDo         :: HsStmtContext Name -> [ExprLStmt id] -> HsExpr id
-mkHsComp       :: HsStmtContext Name -> [ExprLStmt id] -> LHsExpr id -> HsExpr id
+mkHsIntegral   :: Integer -> PostTc RdrName Type -> HsOverLit RdrName
+mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
+mkHsIsString   :: FastString -> PostTc RdrName Type -> HsOverLit RdrName
+mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
+mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
+               -> HsExpr RdrName
 
 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
 
 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
-mkBodyStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
+mkBodyStmt :: Located (bodyR RdrName)
+           -> StmtLR idL RdrName (Located (bodyR RdrName))
 mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
 
-emptyRecStmt :: StmtLR idL idR bodyR
-mkRecStmt    :: [LStmtLR idL idR bodyR] -> StmtLR idL idR bodyR
+emptyRecStmt     :: StmtLR idL  RdrName bodyR
+emptyRecStmtName :: StmtLR Name Name    bodyR
+emptyRecStmtId   :: StmtLR Id   Id      bodyR
+mkRecStmt    :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
 
 
 mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
 mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
 mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
 
-noRebindableInfo :: Bool
-noRebindableInfo = error "noRebindableInfo"    -- Just another placeholder; 
+noRebindableInfo :: PlaceHolder
+noRebindableInfo = PlaceHolder -- Just another placeholder;
 
 mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
@@ -232,7 +249,7 @@ mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
 
 emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
 emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
-                           , trS_stmts = [], trS_bndrs = [] 
+                           , trS_stmts = [], trS_bndrs = []
                            , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
                            , trS_fmap = noSyntaxExpr }
@@ -245,12 +262,22 @@ mkLastStmt body     = LastStmt body noSyntaxExpr
 mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
 mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
 
-emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
-                       , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
-                       , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
-                       , recS_rec_rets = [], recS_ret_ty = placeHolderType }
 
-mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
+emptyRecStmt' :: forall idL idR body.
+                       PostTc idR Type -> StmtLR idL idR body
+emptyRecStmt' tyVal =
+   RecStmt
+     { recS_stmts = [], recS_later_ids = []
+     , recS_rec_ids = []
+     , recS_ret_fn = noSyntaxExpr
+     , recS_mfix_fn = noSyntaxExpr
+     , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
+     , recS_rec_rets = [], recS_ret_ty = tyVal }
+
+emptyRecStmt     = emptyRecStmt' placeHolderType
+emptyRecStmtName = emptyRecStmt' placeHolderType
+emptyRecStmtId   = emptyRecStmt' placeHolderTypeTc
+mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
 
 -------------------------------
 --- A useful function for building @OpApps@.  The operator is always a
@@ -272,16 +299,16 @@ mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind
 
 unqualSplice :: RdrName
 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
-               -- A name (uniquified later) to
-               -- identify the splice
+                -- A name (uniquified later) to
+                -- identify the splice
 
 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
 
 unqualQuasiQuote :: RdrName
 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
-               -- A name (uniquified later) to
-               -- identify the quasi-quote
+                -- A name (uniquified later) to
+                -- identify the quasi-quote
 
 mkHsString :: String -> HsLit
 mkHsString s = HsString (mkFastString s)
@@ -294,9 +321,9 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
 
 
 %************************************************************************
-%*                                                                     *
-       Constructing syntax with no location info
-%*                                                                     *
+%*                                                                      *
+        Constructing syntax with no location info
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -320,44 +347,56 @@ nlHsIntLit n = noLoc (HsLit (HsInt n))
 
 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
-            
+
 nlHsVarApps :: id -> [id] -> LHsExpr id
 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
-                where
-                  mk f a = HsApp (noLoc f) (noLoc a)
+                 where
+                   mk f a = HsApp (noLoc f) (noLoc a)
 
-nlConVarPat :: id -> [id] -> LPat id
+nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 
 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 
-nlConPat :: id -> [LPat id] -> LPat id
+nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 
+nlConPatName :: Name -> [LPat Name] -> LPat Name
+nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
+
 nlNullaryConPat :: id -> LPat id
 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 
 nlWildConPat :: DataCon -> LPat RdrName
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
-                                  (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
+                         (PrefixCon (nOfThem (dataConSourceArity con)
+                                             nlWildPat)))
 
-nlWildPat :: LPat id
-nlWildPat  = noLoc (WildPat placeHolderType  -- Pre-typechecking
+nlWildPat :: LPat RdrName
+nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
 
-nlHsDo :: HsStmtContext Name -> [LStmt id (LHsExpr id)] -> LHsExpr id
+nlWildPatName :: LPat Name
+nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
+
+nlWildPatId :: LPat Id
+nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking
+
+nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
+       -> LHsExpr RdrName
 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 
 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 
-nlHsLam  :: LMatch id (LHsExpr id) -> LHsExpr id
+nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
 nlHsPar  :: LHsExpr id -> LHsExpr id
 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
-nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id
-nlList   :: [LHsExpr id] -> LHsExpr id
+nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
+         -> LHsExpr RdrName
+nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
 
-nlHsLam        match          = noLoc (HsLam (mkMatchGroup Generated [match]))
+nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsIf cond true false = noLoc (mkHsIf cond true false)
 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
@@ -367,9 +406,9 @@ nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 nlHsTyVar :: name                         -> LHsType name
 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 
-nlHsAppTy f t          = noLoc (HsAppTy f t)
-nlHsTyVar x            = noLoc (HsTyVar x)
-nlHsFunTy a b          = noLoc (HsFunTy a b)
+nlHsAppTy f t           = noLoc (HsAppTy f t)
+nlHsTyVar x             = noLoc (HsTyVar x)
+nlHsFunTy a b           = noLoc (HsFunTy a b)
 
 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
@@ -390,15 +429,15 @@ mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 nlTuplePat :: [LPat id] -> Boxity -> LPat id
 nlTuplePat pats box = noLoc (TuplePat pats box [])
 
-missingTupArg :: HsTupArg a
+missingTupArg :: HsTupArg RdrName
 missingTupArg = Missing placeHolderType
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
         Converting a Type to an HsType RdrName
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 This is needed to implement GeneralizedNewtypeDeriving.
@@ -422,7 +461,7 @@ toHsType ty
     to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
     to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
     to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
-       where 
+       where
          args' = filterOut isKind args
          -- Source-language types have _implicit_ kind arguments,
          -- so we must remove them here (Trac #8563)
@@ -446,7 +485,7 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-                | otherwise           = HsWrap co_fn e
+                 | otherwise           = HsWrap co_fn e
 
 mkHsWrapCo :: TcCoercion -> HsExpr id -> HsExpr id
 mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
@@ -464,7 +503,7 @@ coToHsWrapper co | isTcReflCo co = idHsWrapper
 
 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
-                      | otherwise           = CoPat co_fn p ty
+                       | otherwise           = CoPat co_fn p ty
 
 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
@@ -475,13 +514,14 @@ mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
 \end{code}
 l
 %************************************************************************
-%*                                                                     *
-               Bindings; with a location at the top
-%*                                                                     *
+%*                                                                      *
+                Bindings; with a location at the top
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName
+mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
+          -> HsBind RdrName
 -- Not infix, with place holders for coercion and free vars
 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
                           , fun_matches = mkMatchGroup Generated ms
@@ -489,12 +529,14 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
                           , bind_fvs = placeHolderNames
                           , fun_tick = Nothing }
 
-mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name
+mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
+             -> HsBind Name
 -- In Name-land, with empty bind_fvs
 mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
-                                    , fun_matches = mkMatchGroup origin ms
+                                    , fun_matches = mkMatchGroupName origin ms
                                     , fun_co_fn = idHsWrapper
-                                    , bind_fvs = emptyNameSet  -- NB: closed binding
+                                    , bind_fvs = emptyNameSet -- NB: closed
+                                                              --     binding
                                     , fun_tick = Nothing }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
@@ -502,9 +544,10 @@ mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 mkVarBind :: id -> LHsExpr id -> LHsBind id
 mkVarBind var rhs = L (getLoc rhs) $
-                   VarBind { var_id = var, var_rhs = rhs, var_inline = False }
+                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 
-mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
+mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
+             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
 mkPatSynBind name details lpat dir = PatSynBind psb
   where
     psb = PSB{ psb_id = name
@@ -515,25 +558,25 @@ mkPatSynBind name details lpat dir = PatSynBind psb
 
 ------------
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-               -> LHsExpr RdrName -> LHsBind RdrName
+                -> LHsExpr RdrName -> LHsBind RdrName
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
 mkMatch pats expr binds
-  = noLoc (Match (map paren pats) Nothing 
-                (GRHSs (unguardedRHS expr) binds))
+  = noLoc (Match (map paren pats) Nothing
+                 (GRHSs (unguardedRHS expr) binds))
   where
-    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) 
-                    | otherwise          = lp
+    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
+                     | otherwise          = lp
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
-       Collecting binders
-%*                                                                     *
+%*                                                                      *
+        Collecting binders
+%*                                                                      *
 %************************************************************************
 
 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
@@ -574,11 +617,11 @@ collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
 collect_bind (VarBind { var_id = f })     acc = f : acc
 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
-  = map abe_poly dbinds ++ acc 
-       -- ++ foldr collect_bind acc binds
-       -- I don't think we want the binders from the nested binds
-       -- The only time we collect binders from a typechecked 
-       -- binding (hence see AbsBinds) is in zonking in TcHsSyn
+  = map abe_poly dbinds ++ acc
+        -- ++ foldr collect_bind acc binds
+        -- I don't think we want the binders from the nested binds
+        -- The only time we collect binders from a typechecked
+        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc
 
 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
@@ -595,7 +638,7 @@ collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
   where
     get (FunBind { fun_id = f }) fs = f : fs
-    get _                        fs = fs       
+    get _                        fs = fs
        -- Someone else complains about non-FunBinds
 
 ----------------- Statements --------------------------
@@ -632,27 +675,27 @@ collect_lpat :: LPat name -> [name] -> [name]
 collect_lpat (L _ pat) bndrs
   = go pat
   where
-    go (VarPat var)              = var : bndrs
-    go (WildPat _)               = bndrs
-    go (LazyPat pat)             = collect_lpat pat bndrs
-    go (BangPat pat)             = collect_lpat pat bndrs
-    go (AsPat (L _ a) pat)               = a : collect_lpat pat bndrs
+    go (VarPat var)               = var : bndrs
+    go (WildPat _)                = bndrs
+    go (LazyPat pat)              = collect_lpat pat bndrs
+    go (BangPat pat)              = collect_lpat pat bndrs
+    go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
     go (ViewPat _ pat _)          = collect_lpat pat bndrs
-    go (ParPat  pat)             = collect_lpat pat bndrs
-                                 
+    go (ParPat  pat)              = collect_lpat pat bndrs
+
     go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
-    go (PArrPat pats _)          = foldr collect_lpat bndrs pats
-    go (TuplePat pats _ _)       = foldr collect_lpat bndrs pats
-                                 
+    go (PArrPat pats _)           = foldr collect_lpat bndrs pats
+    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
+
     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
-       -- See Note [Dictionary binders in ConPatOut]
-    go (LitPat _)                = bndrs
-    go (NPat _ _ _)              = bndrs
+        -- See Note [Dictionary binders in ConPatOut]
+    go (LitPat _)                 = bndrs
+    go (NPat _ _ _)               = bndrs
     go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
-                                 
-    go (SigPatIn pat _)                  = collect_lpat pat bndrs
-    go (SigPatOut pat _)         = collect_lpat pat bndrs
+
+    go (SigPatIn pat _)           = collect_lpat pat bndrs
+    go (SigPatOut pat _)          = collect_lpat pat bndrs
     go (SplicePat _)              = bndrs
     go (QuasiQuotePat _)          = bndrs
     go (CoPat _ pat _)            = go pat
@@ -698,7 +741,7 @@ hsForeignDeclsBinders foreign_decls
   = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
 
 hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
--- We need to look at instance declarations too, 
+-- We need to look at instance declarations too,
 -- because their associated types may bind data constructors
 hsTyClDeclsBinders tycl_decls inst_decls
   = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
@@ -774,16 +817,16 @@ hsConDeclsBinders cons = go id cons
 
 Note [Binders in family instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a type or data family instance declaration, the type 
+In a type or data family instance declaration, the type
 constructor is an *occurrence* not a binding site
     type instance T Int = Int -> Int   -- No binders
     data instance S Bool = S1 | S2     -- Binders are S1,S2
 
 
 %************************************************************************
-%*                                                                     *
-       Collecting binders the user did not write
-%*                                                                     *
+%*                                                                      *
+        Collecting binders the user did not write
+%*                                                                      *
 %************************************************************************
 
 The job of this family of functions is to run through binding sites and find the set of all Names
@@ -798,7 +841,7 @@ lStmtsImplicits = hs_lstmts
   where
     hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
     hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet
-    
+
     hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
     hs_stmt (LetStmt binds)      = hs_local_binds binds
     hs_stmt (BodyStmt {})        = emptyNameSet
@@ -806,7 +849,7 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (ParStmt xs _ _)     = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
-    
+
     hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
     hs_local_binds (HsIPBinds _)         = emptyNameSet
     hs_local_binds EmptyLocalBinds       = emptyNameSet
@@ -814,7 +857,7 @@ lStmtsImplicits = hs_lstmts
 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
 hsValBindsImplicits (ValBindsOut binds _)
   = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
-hsValBindsImplicits (ValBindsIn binds _) 
+hsValBindsImplicits (ValBindsIn binds _)
   = lhsBindsImplicits binds
 
 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
@@ -827,9 +870,9 @@ lPatImplicits :: LPat Name -> NameSet
 lPatImplicits = hs_lpat
   where
     hs_lpat (L _ pat) = hs_pat pat
-    
+
     hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet
-    
+
     hs_pat (LazyPat pat)       = hs_lpat pat
     hs_pat (BangPat pat)       = hs_lpat pat
     hs_pat (AsPat _ pat)       = hs_lpat pat
@@ -842,12 +885,12 @@ lPatImplicits = hs_lpat
     hs_pat (SigPatIn pat _)  = hs_lpat pat
     hs_pat (SigPatOut pat _) = hs_lpat pat
     hs_pat (CoPat _ pat _)   = hs_pat pat
-    
+
     hs_pat (ConPatIn _ ps)           = details ps
     hs_pat (ConPatOut {pat_args=ps}) = details ps
-    
+
     hs_pat _ = emptyNameSet
-    
+
     details (PrefixCon ps)   = hs_lpats ps
     details (RecCon fs)      = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
       where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
new file mode 100644 (file)
index 0000000..5c536e7
--- /dev/null
@@ -0,0 +1,103 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module PlaceHolder where
+
+import Type       ( Type )
+import Outputable
+import Name
+import NameSet
+import RdrName
+import Var
+import Coercion
+
+import Data.Data hiding ( Fixity )
+import BasicTypes       (Fixity)
+
+
+{-
+%************************************************************************
+%*                                                                      *
+\subsection{Annotating the syntax}
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | used as place holder in PostTc and PostRn values
+data PlaceHolder = PlaceHolder
+  deriving (Data,Typeable)
+
+-- | Types that are not defined until after type checking
+type family PostTc it ty :: * -- Note [Pass sensitive types]
+type instance PostTc Id      ty = ty
+type instance PostTc Name    ty = PlaceHolder
+type instance PostTc RdrName ty = PlaceHolder
+
+-- | Types that are not defined until after renaming
+type family PostRn id ty :: * -- Note [Pass sensitive types]
+type instance PostRn Id      ty = ty
+type instance PostRn Name    ty = ty
+type instance PostRn RdrName ty = PlaceHolder
+
+placeHolderKind :: PlaceHolder
+placeHolderKind = PlaceHolder
+
+placeHolderFixity :: PlaceHolder
+placeHolderFixity = PlaceHolder
+
+placeHolderType :: PlaceHolder
+placeHolderType = PlaceHolder
+
+placeHolderTypeTc :: Type
+placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType"
+
+placeHolderNames :: PlaceHolder
+placeHolderNames = PlaceHolder
+
+placeHolderNamesTc :: NameSet
+placeHolderNamesTc = emptyNameSet
+
+{-
+
+Note [Pass sensitive types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the same AST types are re-used through parsing,renaming and type
+checking there are naturally some places in the AST that do not have
+any meaningful value prior to the pass they are assigned a value.
+
+Historically these have been filled in with place holder values of the form
+
+  panic "error message"
+
+This has meant the AST is difficult to traverse using standed generic
+programming techniques. The problem is addressed by introducing
+pass-specific data types, implemented as a pair of open type families,
+one for PostTc and one for PostRn. These are then explicitly populated
+with a PlaceHolder value when they do not yet have meaning.
+
+Since the required bootstrap compiler at this stage does not have
+closed type families, an open type family had to be used, which
+unfortunately forces the requirement for UndecidableInstances.
+
+In terms of actual usage, we have the following
+
+  PostTc id Kind
+  PostTc id Type
+
+  PostRn id Fixity
+  PostRn id NameSet
+
+TcId and Var are synonyms for Id
+-}
+
+type DataId id =
+  ( Data id
+  , Data (PostRn id NameSet)
+  , Data (PostRn id Fixity)
+  , Data (PostRn id Bool)
+  , Data (PostRn id [Name])
+
+  , Data (PostTc id Type)
+  , Data (PostTc id Coercion)
+  )
index 72dfc88..db7cb10 100644 (file)
@@ -1203,10 +1203,12 @@ atype :: { LHsType RdrName }
                                                       -- see Note [Promotion] for the followings
         | SIMPLEQUOTE qcon                            { LL $ HsTyVar $ unLoc $2 }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
-        | SIMPLEQUOTE  '[' comma_types0 ']'           { LL $ HsExplicitListTy placeHolderKind $3 }
-        | SIMPLEQUOTE var                             { LL $ HsTyVar $ unLoc $2 }
+        | SIMPLEQUOTE  '[' comma_types0 ']'     { LL $ HsExplicitListTy
+                                                       placeHolderKind $3 }
+        | SIMPLEQUOTE var                       { LL $ HsTyVar $ unLoc $2 }
 
-        | '[' ctype ',' comma_types1 ']'              { LL $ HsExplicitListTy placeHolderKind ($2 : $4) }
+        | '[' ctype ',' comma_types1 ']'  { LL $ HsExplicitListTy
+                                                 placeHolderKind ($2 : $4) }
         | INTEGER            {% mkTyLit $ LL $ HsNumTy $ getINTEGER $1 }
         | STRING             {% mkTyLit $ LL $ HsStrTy $ getSTRING  $1 }
 
@@ -1437,7 +1439,9 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
                                         pat <- checkPattern empty e;
                                         return $ LL $ unitOL $ LL $ ValD $
                                                PatBind pat (unLoc $3)
-                                                       placeHolderType placeHolderNames (Nothing,[]) } }
+                                                       placeHolderType
+                                                       placeHolderNames
+                                                       (Nothing,[]) } }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
@@ -1513,16 +1517,20 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { LHsExpr RdrName }
-        : infixexp '::' sigtype         { LL $ ExprWithTySig $1 $3 }
-        | infixexp '-<' exp             { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
-        | infixexp '>-' exp             { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False }
-        | infixexp '-<<' exp            { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
-        | infixexp '>>-' exp            { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
-        | infixexp                      { $1 }
+        : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
+        | infixexp '-<' exp     { LL $ HsArrApp $1 $3 placeHolderType
+                                                      HsFirstOrderApp True }
+        | infixexp '>-' exp     { LL $ HsArrApp $3 $1 placeHolderType
+                                                      HsFirstOrderApp False }
+        | infixexp '-<<' exp    { LL $ HsArrApp $1 $3 placeHolderType
+                                                      HsHigherOrderApp True }
+        | infixexp '>>-' exp    { LL $ HsArrApp $3 $1 placeHolderType
+                                                      HsHigherOrderApp False}
+        | infixexp              { $1 }
 
 infixexp :: { LHsExpr RdrName }
-        : exp10                         { $1 }
-        | infixexp qop exp10            { LL (OpApp $1 $2 (panic "fixity") $3) }
+        : exp10                       { $1 }
+        | infixexp qop exp10          { LL (OpApp $1 $2 placeHolderFixity $3) }
 
 exp10 :: { LHsExpr RdrName }
         : '\\' apat apats opt_asig '->' exp
@@ -1536,7 +1544,9 @@ exp10 :: { LHsExpr RdrName }
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
                                            return (LL $ mkHsIf $2 $5 $8) }
         | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
-                                           return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) }
+                                           return (LL $ HsMultiIf
+                                                      placeHolderType
+                                                      (reverse $ unLoc $2)) }
         | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) }
         | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
 
@@ -1556,7 +1566,7 @@ exp10 :: { LHsExpr RdrName }
                         {% checkPattern empty $2 >>= \ p ->
                             checkCommand $4 >>= \ cmd ->
                             return (LL $ HsProc p (LL $ HsCmdTop cmd placeHolderType
-                                                    placeHolderType undefined)) }
+                                                    placeHolderType [])) }
                                                 -- TODO: is LL right here?
 
         | '{-# CORE' STRING '#-}' exp           { LL $ HsCoreAnn (getSTRING $2) $4 }
@@ -1603,9 +1613,12 @@ aexp2   :: { LHsExpr RdrName }
         | literal                       { L1 (HsLit   $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
 -- into HsOverLit when -foverloaded-strings is on.
---      | STRING                        { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) }
-        | INTEGER                       { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) }
-        | RATIONAL                      { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) }
+--      | STRING     { sL (getLoc $1) (HsOverLit $! mkHsIsString
+--                                        (getSTRING $1) placeHolderType) }
+        | INTEGER    { sL (getLoc $1) (HsOverLit $! mkHsIntegral
+                                          (getINTEGER $1) placeHolderType) }
+        | RATIONAL   { sL (getLoc $1) (HsOverLit $! mkHsFractional
+                                          (getRATIONAL $1) placeHolderType) }
 
         -- N.B.: sections get parsed by these next two productions.
         -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
@@ -1655,7 +1668,8 @@ cmdargs :: { [LHsCmdTop RdrName] }
 
 acmd    :: { LHsCmdTop RdrName }
         : aexp2                 {% checkCommand $1 >>= \ cmd ->
-                                    return (L1 $ HsCmdTop cmd placeHolderType placeHolderType undefined) }
+                                    return (L1 $ HsCmdTop cmd
+                                           placeHolderType placeHolderType []) }
 
 cvtopbody :: { [LHsDecl RdrName] }
         :  '{'            cvtopdecls0 '}'               { $2 }
@@ -1713,8 +1727,9 @@ tup_tail :: { [HsTupArg RdrName] }
 -- avoiding another shift/reduce-conflict.
 
 list :: { LHsExpr RdrName }
-        : texp                  { L1 $ ExplicitList placeHolderType Nothing [$1] }
-        | lexps                 { L1 $ ExplicitList placeHolderType Nothing (reverse (unLoc $1)) }
+        : texp    { L1 $ ExplicitList placeHolderType Nothing [$1] }
+        | lexps   { L1 $ ExplicitList placeHolderType Nothing
+                                                   (reverse (unLoc $1)) }
         | texp '..'             { LL $ ArithSeq noPostTcExpr Nothing (From $1) }
         | texp ',' exp '..'     { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) }
         | texp '..' exp         { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) }
@@ -1737,7 +1752,8 @@ flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
                     -- We just had one thing in our "parallel" list so
                     -- we simply return that thing directly
 
-                    qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss]
+                    qss -> L1 [L1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
+                                            qs <- qss]
                                             noSyntaxExpr noSyntaxExpr]
                     -- We actually found some actual parallel lists so
                     -- we wrap them into as a ParStmt
index 2f95116..6cac513 100644 (file)
@@ -5,6 +5,7 @@ Functions over HsSyn specialised to RdrName.
 
 \begin{code}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module RdrHsSyn (
         mkHsOpApp,
@@ -720,7 +721,8 @@ checkAPat msg loc e0 = do
    ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
    EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
    -- view pattern is well-formed if the pattern is
-   EViewPat expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat expr p placeHolderType))
+   EViewPat expr patE -> checkLPat msg patE >>=
+                            (return . (\p -> ViewPat expr p placeHolderType))
    ExprWithTySig e t  -> do e <- checkLPat msg e
                             -- Pattern signatures are parsed as sigtypes,
                             -- but they aren't explicit forall points.  Hence
@@ -817,7 +819,8 @@ checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
 
-makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id
+makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)]
+            -> HsBind RdrName
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn is_infix ms
   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms,
@@ -995,13 +998,13 @@ checkCmd _ (HsLet lb e) =
 checkCmd _ (HsDo DoExpr stmts ty) = 
     mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty)
 
-checkCmd _ (OpApp eLeft op fixity eRight) = do
+checkCmd _ (OpApp eLeft op _fixity eRight) = do
     -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
     c1 <- checkCommand eLeft
     c2 <- checkCommand eRight
     let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
         arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
-    return $ HsCmdArrForm op (Just fixity) [arg1, arg2]
+    return $ HsCmdArrForm op Nothing [arg1, arg2]
 
 checkCmd l e = cmdFail l e
 
index 0f9f44a..dfbde13 100644 (file)
@@ -46,14 +46,14 @@ import NameEnv
 import NameSet
 import RdrName          ( RdrName, rdrNameOcc )
 import SrcLoc
-import ListSetOps      ( findDupsEq )
-import BasicTypes      ( RecFlag(..) )
-import Digraph         ( SCC(..) )
+import ListSetOps       ( findDupsEq )
+import BasicTypes       ( RecFlag(..) )
+import Digraph          ( SCC(..) )
 import Bag
 import Outputable
 import FastString
-import Data.List       ( partition, sort )
-import Maybes          ( orElse )
+import Data.List        ( partition, sort )
+import Maybes           ( orElse )
 import Control.Monad
 import Data.Traversable ( traverse )
 \end{code}
@@ -66,7 +66,7 @@ in where-clauses which are all apparently mutually recursive, but which may
 not really depend upon each other. For example, in the top level program
 \begin{verbatim}
 f x = y where a = x
-             y = x
+              y = x
 \end{verbatim}
 the definitions of @a@ and @y@ do not depend on each other at all.
 Unfortunately, the typechecker cannot always check such definitions.
@@ -86,9 +86,9 @@ within one @MonoBinds@, so that unique-Int plumbing is done explicitly
 
 
 %************************************************************************
-%*                                                                     *
-%* naming conventions                                                  *
-%*                                                                     *
+%*                                                                      *
+%* naming conventions                                                   *
+%*                                                                      *
 %************************************************************************
 
 \subsection[name-conventions]{Name conventions}
@@ -113,9 +113,9 @@ a set of variables free in @Exp@ is written @fvExp@
 \end{itemize}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 %* analysing polymorphic bindings (HsBindGroup, HsBind)
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \subsubsection[dep-HsBinds]{Polymorphic bindings}
@@ -154,48 +154,48 @@ union of those in the previous set plus those of the newest binding after
 the defined variables of the previous set have been removed.
 
 @rnMethodBinds@ deals only with the declarations in class and
-instance declarations. It expects only to see @FunMonoBind@s, and
+instance declarations.  It expects only to see @FunMonoBind@s, and
 it expects the global environment to contain bindings for the binders
 (which are all class operations).
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsubsection{ Top-level bindings}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 -- for top-level bindings, we need to make top-level names,
 -- so we have a different entry point than for local bindings
 rnTopBindsLHS :: MiniFixityEnv
-              -> HsValBinds RdrName 
+              -> HsValBinds RdrName
               -> RnM (HsValBindsLR Name RdrName)
 rnTopBindsLHS fix_env binds
   = rnValBindsLHS (topRecNameMaker fix_env) binds
 
-rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName 
+rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName
               -> RnM (HsValBinds Name, DefUses)
 rnTopBindsRHS bound_names binds
   = do { is_boot <- tcIsHsBoot
-       ; if is_boot 
+       ; if is_boot
          then rnTopBindsBoot binds
          else rnValBindsRHS (TopSigCtxt bound_names False) binds }
 
 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
--- A hs-boot file has no bindings. 
+-- A hs-boot file has no bindings.
 -- Return a single HsBindGroup with empty binds and renamed signatures
 rnTopBindsBoot (ValBindsIn mbinds sigs)
-  = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
-       ; (sigs', fvs) <- renameSigs HsBootCtxt sigs
-       ; return (ValBindsOut [] sigs', usesOnly fvs) }
+  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
+        ; (sigs', fvs) <- renameSigs HsBootCtxt sigs
+        ; return (ValBindsOut [] sigs', usesOnly fvs) }
 rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
 \end{code}
 
 
 %*********************************************************
-%*                                                     *
-               HsLocalBinds
-%*                                                     *
+%*                                                      *
+                HsLocalBinds
+%*                                                      *
 %*********************************************************
 
 \begin{code}
@@ -203,13 +203,13 @@ rnLocalBindsAndThen :: HsLocalBinds RdrName
                     -> (HsLocalBinds Name -> RnM (result, FreeVars))
                     -> RnM (result, FreeVars)
 -- This version (a) assumes that the binding vars are *not* already in scope
---              (b) removes the binders from the free vars of the thing inside
+--               (b) removes the binders from the free vars of the thing inside
 -- The parser doesn't produce ThenBinds
 rnLocalBindsAndThen EmptyLocalBinds thing_inside
   = thing_inside EmptyLocalBinds
 
 rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
-  = rnLocalValBindsAndThen val_binds $ \ val_binds' -> 
+  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
       thing_inside (HsValBinds val_binds')
 
 rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
@@ -230,38 +230,38 @@ rnIPBind (IPBind ~(Left n) expr) = do
 
 
 %************************************************************************
-%*                                                                     *
-               ValBinds
-%*                                                                     *
+%*                                                                      *
+                ValBinds
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
--- Renaming local binding gropus 
+-- Renaming local binding groups
 -- Does duplicate/shadow check
 rnLocalValBindsLHS :: MiniFixityEnv
                    -> HsValBinds RdrName
                    -> RnM ([Name], HsValBindsLR Name RdrName)
-rnLocalValBindsLHS fix_env binds 
-  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds 
+rnLocalValBindsLHS fix_env binds
+  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
 
          -- Check for duplicates and shadowing
-        -- Must do this *after* renaming the patterns
-        -- See Note [Collect binders only after renaming] in HsUtils
+         -- Must do this *after* renaming the patterns
+         -- See Note [Collect binders only after renaming] in HsUtils
 
          -- We need to check for dups here because we
-        -- don't don't bind all of the variables from the ValBinds at once
-        -- with bindLocatedLocals any more.
-         -- 
-        -- Note that we don't want to do this at the top level, since
-        -- sorting out duplicates and shadowing there happens elsewhere.
-        -- The behavior is even different. For example,
-        --   import A(f)
-        --   f = ...
-        -- should not produce a shadowing warning (but it will produce
-        -- an ambiguity warning if you use f), but
-        --   import A(f)
-        --   g = let f = ... in f
-        -- should.
+         -- don't don't bind all of the variables from the ValBinds at once
+         -- with bindLocatedLocals any more.
+         --
+         -- Note that we don't want to do this at the top level, since
+         -- sorting out duplicates and shadowing there happens elsewhere.
+         -- The behavior is even different. For example,
+         --   import A(f)
+         --   f = ...
+         -- should not produce a shadowing warning (but it will produce
+         -- an ambiguity warning if you use f), but
+         --   import A(f)
+         --   g = let f = ... in f
+         -- should.
        ; let bound_names = collectHsValBinders binds'
        ; envs <- getRdrEnvs
        ; checkDupAndShadowedNames envs bound_names
@@ -271,7 +271,7 @@ rnLocalValBindsLHS fix_env binds
 -- renames the left-hand sides
 -- generic version used both at the top level and for local binds
 -- does some error checking, but not what gets done elsewhere at the top level
-rnValBindsLHS :: NameMaker 
+rnValBindsLHS :: NameMaker
               -> HsValBinds RdrName
               -> RnM (HsValBindsLR Name RdrName)
 rnValBindsLHS topP (ValBindsIn mbinds sigs)
@@ -287,7 +287,7 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
 -- Assumes the LHS vars are in scope
 --
 -- Does not bind the local fixity declarations
-rnValBindsRHS :: HsSigCtxt 
+rnValBindsRHS :: HsSigCtxt
               -> HsValBindsLR Name RdrName
               -> RnM (HsValBinds Name, DefUses)
 
@@ -299,9 +299,9 @@ rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
               where
                 valbind' = ValBindsOut anal_binds sigs'
                 valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
-                              -- Put the sig uses *after* the bindings
-                              -- so that the binders are removed from 
-                              -- the uses in the sigs
+                               -- Put the sig uses *after* the bindings
+                               -- so that the binders are removed from
+                               -- the uses in the sigs
        }
 
 rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
@@ -319,7 +319,7 @@ rnLocalValBindsRHS bound_names binds
   = rnValBindsRHS (LocalBindCtxt bound_names) binds
 
 -- for local binds
--- wrapper that does both the left- and right-hand sides 
+-- wrapper that does both the left- and right-hand sides
 --
 -- here there are no local fixity decls passed in;
 -- the local fixity decls come from the ValBinds sigs
@@ -327,58 +327,61 @@ rnLocalValBindsAndThen :: HsValBinds RdrName
                        -> (HsValBinds Name -> RnM (result, FreeVars))
                        -> RnM (result, FreeVars)
 rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
- = do  {     -- (A) Create the local fixity environment 
-         new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
+ = do   {     -- (A) Create the local fixity environment
+          new_fixities <- makeMiniFixityEnv [L loc sig
+                                                  | L loc (FixSig sig) <- sigs]
 
-             -- (B) Rename the LHSes 
-       ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
+              -- (B) Rename the LHSes
+        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
 
-             --     ...and bring them (and their fixities) into scope
-       ; bindLocalNamesFV bound_names              $
+              --     ...and bring them (and their fixities) into scope
+        ; bindLocalNamesFV bound_names              $
           addLocalFixities new_fixities bound_names $ do
 
-       {      -- (C) Do the RHS and thing inside
-         (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs 
+        {      -- (C) Do the RHS and thing inside
+          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
         ; (result, result_fvs) <- thing_inside binds'
 
-               -- Report unused bindings based on the (accurate) 
-               -- findUses.  E.g.
-               --      let x = x in 3
-               -- should report 'x' unused
-       ; let real_uses = findUses dus result_fvs
-             -- Insert fake uses for variables introduced implicitly by wildcards (#4404)
-             implicit_uses = hsValBindsImplicits binds'
-       ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses)
-
-       ; let
-            -- The variables "used" in the val binds are: 
+                -- Report unused bindings based on the (accurate)
+                -- findUses.  E.g.
+                --      let x = x in 3
+                -- should report 'x' unused
+        ; let real_uses = findUses dus result_fvs
+              -- Insert fake uses for variables introduced implicitly by
+              -- wildcards (#4404)
+              implicit_uses = hsValBindsImplicits binds'
+        ; warnUnusedLocalBinds bound_names
+                                      (real_uses `unionNameSets` implicit_uses)
+
+        ; let
+            -- The variables "used" in the val binds are:
             --   (1) the uses of the binds (allUses)
             --   (2) the FVs of the thing-inside
             all_uses = allUses dus `plusFV` result_fvs
-               -- Note [Unused binding hack]
-               -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-               -- Note that *in contrast* to the above reporting of
-               -- unused bindings, (1) above uses duUses to return *all* 
-               -- the uses, even if the binding is unused.  Otherwise consider:
-                --     x = 3
-                --     y = let p = x in 'x'    -- NB: p not used
+                -- Note [Unused binding hack]
+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+                -- Note that *in contrast* to the above reporting of
+                -- unused bindings, (1) above uses duUses to return *all*
+                -- the uses, even if the binding is unused.  Otherwise consider:
+                --      x = 3
+                --      y = let p = x in 'x'    -- NB: p not used
                 -- If we don't "see" the dependency of 'y' on 'x', we may put the
                 -- bindings in the wrong order, and the type checker will complain
                 -- that x isn't in scope
-               --
-               -- But note that this means we won't report 'x' as unused, 
-               -- whereas we would if we had { x = 3; p = x; y = 'x' }
+                --
+                -- But note that this means we won't report 'x' as unused,
+                -- whereas we would if we had { x = 3; p = x; y = 'x' }
 
-       ; return (result, all_uses) }}
-               -- The bound names are pruned out of all_uses
-               -- by the bindLocalNamesFV call above
+        ; return (result, all_uses) }}
+                -- The bound names are pruned out of all_uses
+                -- by the bindLocalNamesFV call above
 
 rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
 
 
 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
 -- (We keep the location around for reporting duplicate fixity declarations.)
--- 
+--
 -- Checks for duplicates, but not that only locally defined things are fixed.
 -- Note: for local fixity declarations, duplicates would also be checked in
 --       check_sigs below.  But we also use this function at the top level.
@@ -398,7 +401,7 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
        case lookupFsEnv env fs of
          Nothing -> return $ extendFsEnv env fs fix_item
          Just (L loc' _) -> do
-           { setSrcSpan loc $ 
+           { setSrcSpan loc $
              addErrAt name_loc (dupFixityDecl loc' name)
            ; return env}
      }
@@ -406,14 +409,14 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
 dupFixityDecl :: SrcSpan -> RdrName -> SDoc
 dupFixityDecl loc rdr_name
   = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
-         ptext (sLit "also at ") <+> ppr loc]
+          ptext (sLit "also at ") <+> ppr loc]
 
 ---------------------
 
 -- renaming a single bind
 
 rnBindLHS :: NameMaker
-          -> SDoc 
+          -> SDoc
           -> HsBind RdrName
           -- returns the renamed left-hand side,
           -- and the FreeVars *of the LHS*
@@ -431,7 +434,8 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
 
 rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
   = do { newname <- applyNameMaker name_maker name
-       ; return (bind { fun_id = L nameLoc newname }) } 
+       ; return (bind { fun_id = L nameLoc newname
+                      , bind_fvs = placeHolderNamesTc }) }
 
 rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
   = do { unless (isTopRecNameMaker name_maker) $
@@ -447,7 +451,7 @@ rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
 
 rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
 
-rnLBind :: (Name -> [Name])            -- Signature tyvar function
+rnLBind :: (Name -> [Name])             -- Signature tyvar function
         -> LHsBindLR Name RdrName
         -> RnM (LHsBind Name, [Name], Uses)
 rnLBind sig_fn (L loc bind)
@@ -456,25 +460,26 @@ rnLBind sig_fn (L loc bind)
        ; return (L loc bind', bndrs, dus) }
 
 -- assumes the left-hands-side vars are in scope
-rnBind :: (Name -> [Name])             -- Signature tyvar function
+rnBind :: (Name -> [Name])              -- Signature tyvar function
        -> HsBindLR Name RdrName
        -> RnM (HsBind Name, [Name], Uses)
 rnBind _ bind@(PatBind { pat_lhs = pat
-                       , pat_rhs = grhss 
+                       , pat_rhs = grhss
                                    -- pat fvs were stored in bind_fvs
                                    -- after processing the LHS
                        , bind_fvs = pat_fvs })
-  = do { mod <- getModule
+  = do  { mod <- getModule
         ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
 
-               -- No scoped type variables for pattern bindings
-       ; let all_fvs = pat_fvs `plusFV` rhs_fvs
+                -- No scoped type variables for pattern bindings
+        ; let all_fvs = pat_fvs `plusFV` rhs_fvs
               fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs
-               -- Keep locally-defined Names
-               -- As well as dependency analysis, we need these for the
-               -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
               bndrs = collectPatBinders pat
-              bind' = bind { pat_rhs  = grhss', bind_fvs = fvs' }
+              bind' = bind { pat_rhs  = grhss',
+                             pat_rhs_ty = placeHolderType, bind_fvs = fvs' }
               is_wild_pat = case pat of
                               L _ (WildPat {})                 -> True
                               L _ (BangPat (L _ (WildPat {}))) -> True -- #9127
@@ -489,30 +494,31 @@ rnBind _ bind@(PatBind { pat_lhs = pat
           when (null bndrs && not is_wild_pat) $
           addWarn $ unusedPatBindWarn bind'
 
-       ; fvs' `seq` -- See Note [Free-variable space leak]
+        ; fvs' `seq` -- See Note [Free-variable space leak]
           return (bind', bndrs, all_fvs) }
 
-rnBind sig_fn bind@(FunBind { fun_id = name 
-                            , fun_infix = is_infix 
-                            , fun_matches = matches }) 
+rnBind sig_fn bind@(FunBind { fun_id = name
+                            , fun_infix = is_infix
+                            , fun_matches = matches })
        -- invariant: no free vars here when it's a FunBind
-  = do { let plain_name = unLoc name
+  = do  { let plain_name = unLoc name
 
-       ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-                               -- bindSigTyVars tests for Opt_ScopedTyVars
-                                rnMatchGroup (FunRhs plain_name is_infix) rnLExpr matches
-       ; when is_infix $ checkPrecMatch plain_name matches'
+        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
+                                -- bindSigTyVars tests for Opt_ScopedTyVars
+                                 rnMatchGroup (FunRhs plain_name is_infix)
+                                              rnLExpr matches
+        ; when is_infix $ checkPrecMatch plain_name matches'
 
         ; mod <- getModule
         ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
-               -- Keep locally-defined Names
-               -- As well as dependency analysis, we need these for the
-               -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
 
-       ; fvs' `seq` -- See Note [Free-variable space leak]
+        ; fvs' `seq` -- See Note [Free-variable space leak]
           return (bind { fun_matches = matches'
-                      , bind_fvs   = fvs' },
-                 [plain_name], rhs_fvs)
+                       , bind_fvs   = fvs' },
+                  [plain_name], rhs_fvs)
       }
 
 rnBind sig_fn (PatSynBind bind)
@@ -534,7 +540,7 @@ and we don't want to retain the list bound_names. This showed up in
 trac ticket #1136.
 -}
 
-rnPatSynBind :: (Name -> [Name])               -- Signature tyvar function
+rnPatSynBind :: (Name -> [Name])                -- Signature tyvar function
              -> PatSynBind Name RdrName
              -> RnM (PatSynBind Name Name, [Name], Uses)
 rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
@@ -542,7 +548,7 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
                                , psb_def = pat
                                , psb_dir = dir })
        -- invariant: no free vars here when it's a FunBind
-  = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms
+  = do  { pattern_synonym_ok <- xoptM Opt_PatternSynonyms
         ; unless pattern_synonym_ok (addErr patternSynonymErr)
 
         ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do
@@ -571,9 +577,9 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
         ; mod <- getModule
         ; let fvs = fvs1 `plusFV` fvs2
               fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
-               -- Keep locally-defined Names
-               -- As well as dependency analysis, we need these for the
-               -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
 
         ; let bind' = bind{ psb_args = details'
                           , psb_def = pat'
@@ -624,8 +630,8 @@ P' which is unsound and rejected).
 
 ---------------------
 depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
-            -> ([(RecFlag, LHsBinds Name)], DefUses)
--- Dependency analysis; this is important so that 
+             -> ([(RecFlag, LHsBinds Name)], DefUses)
+-- Dependency analysis; this is important so that
 -- unused-binding reporting is accurate
 depAnalBinds binds_w_dus
   = (map get_binds sccs, map get_du sccs)
@@ -639,21 +645,21 @@ depAnalBinds binds_w_dus
 
     get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
     get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
-       where
-         defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
-         uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
+        where
+          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
+          uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
 
 ---------------------
 -- Bind the top-level forall'd type variables in the sigs.
--- E.g         f :: a -> a
---     f = rhs
---     The 'a' scopes over the rhs
+-- E.g  f :: a -> a
+--      f = rhs
+--      The 'a' scopes over the rhs
 --
 -- NB: there'll usually be just one (for a function binding)
 --     but if there are many, one may shadow the rest; too bad!
---     e.g  x :: [a] -> [a]
---          y :: [(a,a)] -> a
---          (x,y) = e
+--      e.g  x :: [a] -> [a]
+--           y :: [(a,a)] -> a
+--           (x,y) = e
 --      In e, 'a' will be in scope, and it'll be the one from 'y'!
 
 mkSigTvFn :: [LSig Name] -> (Name -> [Name])
@@ -664,11 +670,11 @@ mkSigTvFn sigs
   where
     env :: NameEnv [Name]
     env = mkNameEnv [ (name, hsLKiTyVarNames ltvs)  -- Kind variables and type variables
-                   | L _ (TypeSig names
-                                  (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
+                    | L _ (TypeSig names
+                                   (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
                     , (L _ name) <- names]
-       -- Note the pattern-match on "Explicit"; we only bind
-       -- type variables from signatures with an explicit top-level for-all
+        -- Note the pattern-match on "Explicit"; we only bind
+        -- type variables from signatures with an explicit top-level for-all
 \end{code}
 
 
@@ -678,8 +684,8 @@ declaration.   Like @rnBinds@ but without dependency analysis.
 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
 That's crucial when dealing with an instance decl:
 \begin{verbatim}
-       instance Foo (T a) where
-          op x = ...
+        instance Foo (T a) where
+           op x = ...
 \end{verbatim}
 This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
 and unless @op@ occurs we won't treat the type signature of @op@ in the class
@@ -688,48 +694,50 @@ in many ways the @op@ in an instance decl is just like an occurrence, not
 a binder.
 
 \begin{code}
-rnMethodBinds :: Name                  -- Class name
-             -> (Name -> [Name])       -- Signature tyvar function
-             -> LHsBinds RdrName
-             -> RnM (LHsBinds Name, FreeVars)
+rnMethodBinds :: Name                   -- Class name
+              -> (Name -> [Name])       -- Signature tyvar function
+              -> LHsBinds RdrName
+              -> RnM (LHsBinds Name, FreeVars)
 
 rnMethodBinds cls sig_fn binds
   = do { checkDupRdrNames meth_names
-            -- Check that the same method is not given twice in the
-            -- same instance decl      instance C T where
-            --                       f x = ...
-            --                       g y = ...
-            --                       f x = ...
-            -- We must use checkDupRdrNames because the Name of the
-            -- method is the Name of the class selector, whose SrcSpan
-            -- points to the class declaration; and we use rnMethodBinds
-            -- for instance decls too
+             -- Check that the same method is not given twice in the
+             -- same instance decl      instance C T where
+             --                       f x = ...
+             --                       g y = ...
+             --                       f x = ...
+             -- We must use checkDupRdrNames because the Name of the
+             -- method is the Name of the class selector, whose SrcSpan
+             -- points to the class declaration; and we use rnMethodBinds
+             -- for instance decls too
 
        ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
-  where 
+  where
     meth_names  = collectMethodBinders binds
     do_one (binds,fvs) bind
        = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
-           ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
+            ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
 
 rnMethodBind :: Name
-             -> (Name -> [Name])
-             -> LHsBindLR RdrName RdrName
-             -> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn 
-             (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix 
-                                 , fun_matches = MG { mg_alts = matches, mg_origin = origin } }))
+              -> (Name -> [Name])
+              -> LHsBindLR RdrName RdrName
+              -> RnM (Bag (LHsBindLR Name Name), FreeVars)
+rnMethodBind cls sig_fn
+             (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
+                                  , fun_matches = MG { mg_alts = matches
+                                                     , mg_origin = origin } }))
   = setSrcSpan loc $ do
     sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
     let plain_name = unLoc sel_name
         -- We use the selector name as the binder
 
     (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-                          mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches
-    let new_group = mkMatchGroup origin new_matches
+                          mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr)
+                                           matches
+    let new_group = mkMatchGroupName origin new_matches
 
     when is_infix $ checkPrecMatch plain_name new_group
-    return (unitBag (L loc (bind { fun_id      = sel_name 
+    return (unitBag (L loc (bind { fun_id      = sel_name
                                  , fun_matches = new_group
                                  , bind_fvs    = fvs })),
              fvs `addOneFV` plain_name)
@@ -746,9 +754,9 @@ rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 @renameSigs@ checks for:
@@ -761,28 +769,28 @@ At the moment we don't gather free-var info from the types in
 signatures.  We'd only need this if we wanted to report unused tyvars.
 
 \begin{code}
-renameSigs :: HsSigCtxt 
-          -> [LSig RdrName]
-          -> RnM ([LSig Name], FreeVars)
+renameSigs :: HsSigCtxt
+           -> [LSig RdrName]
+           -> RnM ([LSig Name], FreeVars)
 -- Renames the signatures and performs error checks
-renameSigs ctxt sigs 
-  = do { mapM_ dupSigDeclErr (findDupSigs sigs)
+renameSigs ctxt sigs
+  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)
 
-       ; checkDupMinimalSigs sigs
+        ; checkDupMinimalSigs sigs
 
-       ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
+        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
 
-       ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
-       ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
+        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
+        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
 
-       ; return (good_sigs, sig_fvs) } 
+        ; return (good_sigs, sig_fvs) }
 
 ----------------------
 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
 -- because this won't work for:
---     instance Foo T where
---       {-# INLINE op #-}
---       Baz.op = ...
+--      instance Foo T where
+--        {-# INLINE op #-}
+--        Baz.op = ...
 -- We'll just rename the INLINE prag to refer to whatever other 'op'
 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
 -- Doesn't seem worth much trouble to sort this.
@@ -790,49 +798,49 @@ renameSigs ctxt sigs
 renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
 -- FixitySig is renamed elsewhere.
 renameSig _ (IdSig x)
-  = return (IdSig x, emptyFVs)   -- Actually this never occurs
+  = return (IdSig x, emptyFVs)    -- Actually this never occurs
 
 renameSig ctxt sig@(TypeSig vs ty)
-  = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
-       ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
-       ; return (TypeSig new_vs new_ty, fvs) }
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+        ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+        ; return (TypeSig new_vs new_ty, fvs) }
 
 renameSig ctxt sig@(GenericSig vs ty)
-  = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
+  = do  { defaultSigs_on <- xoptM Opt_DefaultSignatures
         ; unless defaultSigs_on (addErr (defaultSigErr sig))
         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
-       ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
-       ; return (GenericSig new_v new_ty, fvs) }
+        ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+        ; return (GenericSig new_v new_ty, fvs) }
 
 renameSig _ (SpecInstSig ty)
-  = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
-       ; return (SpecInstSig new_ty,fvs) }
+  = do  { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
+        ; return (SpecInstSig new_ty,fvs) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
 -- so, in the top-level case (when mb_names is Nothing)
 -- we use lookupOccRn.  If there's both an imported and a local 'f'
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
 renameSig ctxt sig@(SpecSig v ty inl)
-  = do { new_v <- case ctxt of 
+  = do  { new_v <- case ctxt of
                      TopSigCtxt {} -> lookupLocatedOccRn v
                      _             -> lookupSigOccRn ctxt sig v
-       ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
-       ; return (SpecSig new_v new_ty inl, fvs) }
+        ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
+        ; return (SpecSig new_v new_ty inl, fvs) }
 
 renameSig ctxt sig@(InlineSig v s)
-  = do { new_v <- lookupSigOccRn ctxt sig v
-       ; return (InlineSig new_v s, emptyFVs) }
+  = do  { new_v <- lookupSigOccRn ctxt sig v
+        ; return (InlineSig new_v s, emptyFVs) }
 
 renameSig ctxt sig@(FixSig (FixitySig v f))
-  = do { new_v <- lookupSigOccRn ctxt sig v
-       ; return (FixSig (FixitySig new_v f), emptyFVs) }
+  = do  { new_v <- lookupSigOccRn ctxt sig v
+        ; return (FixSig (FixitySig new_v f), emptyFVs) }
 
 renameSig ctxt sig@(MinimalSig bf)
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
        return (MinimalSig new_bf, emptyFVs)
 
 renameSig ctxt sig@(PatSynSig v args ty prov req)
-  = do v' <- lookupSigOccRn ctxt sig v
+  = do  v' <- lookupSigOccRn ctxt sig v
         let doc = quotes (ppr v)
             rn_type = rnHsSigType doc
         (ty', fvs1) <- rn_type ty
@@ -853,7 +861,7 @@ ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 
 okHsSig :: HsSigCtxt -> LSig a -> Bool
-okHsSig ctxt (L _ sig) 
+okHsSig ctxt (L _ sig)
   = case (sig, ctxt) of
      (GenericSig {}, ClsDeclCtxt {}) -> True
      (GenericSig {}, _)              -> False
@@ -886,13 +894,13 @@ okHsSig ctxt (L _ sig)
 
 -------------------
 findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
--- Check for duplicates on RdrName version, 
+-- Check for duplicates on RdrName version,
 -- because renamed version has unboundName for
 -- not-in-scope binders, which gives bogus dup-sig errors
--- NB: in a class decl, a 'generic' sig is not considered 
+-- NB: in a class decl, a 'generic' sig is not considered
 --     equal to an ordinary sig, so we allow, say
---                  class C a where
---            op :: a -> a
+--           class C a where
+--             op :: a -> a
 --             default op :: Eq a => a -> a
 findDupSigs sigs
   = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
@@ -920,9 +928,9 @@ checkDupMinimalSigs sigs
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Match}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -930,11 +938,11 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
              -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
              -> MatchGroup RdrName (Located (body RdrName))
              -> RnM (MatchGroup Name (Located (body Name)), FreeVars)
-rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) 
+rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin })
   = do { empty_case_ok <- xoptM Opt_EmptyCase
        ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
-       ; return (mkMatchGroup origin new_ms, ms_fvs) }
+       ; return (mkMatchGroupName origin new_ms, ms_fvs) }
 
 rnMatch :: Outputable (body RdrName) => HsMatchContext Name
         -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
@@ -942,22 +950,22 @@ rnMatch :: Outputable (body RdrName) => HsMatchContext Name
         -> RnM (LMatch Name (Located (body Name)), FreeVars)
 rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
 
-rnMatch' :: Outputable (body RdrName) => HsMatchContext Name 
+rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
          -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
          -> Match RdrName (Located (body RdrName))
          -> RnM (Match Name (Located (body Name)), FreeVars)
 rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss)
-  = do         {       -- Result type signatures are no longer supported
-         case maybe_rhs_sig of 
-               Nothing -> return ()
-               Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
+  = do  {       -- Result type signatures are no longer supported
+          case maybe_rhs_sig of
+                Nothing -> return ()
+                Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
 
-              -- Now the main event
-              -- note that there are no local ficity decls for matches
-       ; rnPats ctxt pats      $ \ pats' -> do
-       { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
+               -- Now the main event
+               -- note that there are no local ficity decls for matches
+        ; rnPats ctxt pats      $ \ pats' -> do
+        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
 
-       ; return (Match pats' Nothing grhss', grhss_fvs) }}
+        ; return (Match pats' Nothing grhss', grhss_fvs) }}
 
 emptyCaseErr :: HsMatchContext Name -> SDoc
 emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt)
@@ -967,71 +975,73 @@ emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ct
                 CaseAlt    -> ptext (sLit "case expression")
                 LambdaExpr -> ptext (sLit "\\case expression")
                 _ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt
 
-resSigErr :: Outputable body => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc 
+
+resSigErr :: Outputable body
+          => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc
 resSigErr ctxt match ty
    = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
-         , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches")
-         , pprMatchInCtxt ctxt match ]
+          , nest 2 $ ptext (sLit
+                 "Result signatures are no longer supported in pattern matches")
+          , pprMatchInCtxt ctxt match ]
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsubsection{Guarded right-hand sides (GRHSs)}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-rnGRHSs :: HsMatchContext Name 
+rnGRHSs :: HsMatchContext Name
         -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
         -> GRHSs RdrName (Located (body RdrName))
         -> RnM (GRHSs Name (Located (body Name)), FreeVars)
 rnGRHSs ctxt rnBody (GRHSs grhss binds)
-  = rnLocalBindsAndThen binds  $ \ binds' -> do
+  = rnLocalBindsAndThen binds   $ \ binds' -> do
     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
     return (GRHSs grhss' binds', fvGRHSs)
 
-rnGRHS :: HsMatchContext Name 
+rnGRHS :: HsMatchContext Name
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
        -> LGRHS RdrName (Located (body RdrName))
        -> RnM (LGRHS Name (Located (body Name)), FreeVars)
 rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
 
-rnGRHS' :: HsMatchContext Name 
+rnGRHS' :: HsMatchContext Name
         -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
         -> GRHS RdrName (Located (body RdrName))
         -> RnM (GRHS Name (Located (body Name)), FreeVars)
 rnGRHS' ctxt rnBody (GRHS guards rhs)
-  = do { pattern_guards_allowed <- xoptM Opt_PatternGuards
+  = do  { pattern_guards_allowed <- xoptM Opt_PatternGuards
         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
-                                   rnBody rhs
+                                    rnBody rhs
 
-       ; unless (pattern_guards_allowed || is_standard_guard guards')
-                (addWarn (nonStdGuardErr guards'))
+        ; unless (pattern_guards_allowed || is_standard_guard guards')
+                 (addWarn (nonStdGuardErr guards'))
 
-       ; return (GRHS guards' rhs', fvs) }
+        ; return (GRHS guards' rhs', fvs) }
   where
-       -- Standard Haskell 1.4 guards are just a single boolean
-       -- expression, rather than a list of qualifiers as in the
-       -- Glasgow extension
+        -- Standard Haskell 1.4 guards are just a single boolean
+        -- expression, rather than a list of qualifiers as in the
+        -- Glasgow extension
     is_standard_guard []                       = True
     is_standard_guard [L _ (BodyStmt _ _ _ _)] = True
     is_standard_guard _                        = False
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Error messages}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM ()
 dupSigDeclErr pairs@((L loc name, sig) : _)
   = addErrAt loc $
-    vcat [ ptext (sLit "Duplicate") <+> what_it_is 
+    vcat [ ptext (sLit "Duplicate") <+> what_it_is
            <> ptext (sLit "s for") <+> quotes (ppr name)
          , ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]
   where
index 4e5076a..2872b48 100644 (file)
@@ -207,9 +207,10 @@ rnExpr (HsLam matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
        ; return (HsLam matches', fvMatch) }
 
-rnExpr (HsLamCase arg matches)
+rnExpr (HsLamCase _arg matches)
   = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
-       ; return (HsLamCase arg matches', fvs_ms) }
+       -- ; return (HsLamCase arg matches', fvs_ms) }
+       ; return (HsLamCase placeHolderType matches', fvs_ms) }
 
 rnExpr (HsCase expr matches)
   = do { (new_expr, e_fvs) <- rnLExpr expr
@@ -231,7 +232,8 @@ rnExpr (ExplicitList _ _  exps)
         ; if opt_OverloadedLists
            then do {
             ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
-            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') }
+            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
+                     , fvs `plusFV` fvs') }
            else
             return  (ExplicitList placeHolderType Nothing exps', fvs) }
 
@@ -273,9 +275,10 @@ rnExpr (HsIf _ p b1 b2)
        ; (mb_ite, fvITE) <- lookupIfThenElse
        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
-rnExpr (HsMultiIf ty alts)
+rnExpr (HsMultiIf _ty alts)
   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
-       ; return (HsMultiIf ty alts', fvs) }
+       -- ; return (HsMultiIf ty alts', fvs) }
+       ; return (HsMultiIf placeHolderType alts', fvs) }
 
 rnExpr (HsType a)
   = do { (t, fvT) <- rnLHsType HsTypeCtx a
@@ -404,7 +407,8 @@ rnCmdTop = wrapLocFstM rnCmdTop'
         -- Generate the rebindable syntax for the monad
         ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
 
-        ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'),
+        ; return (HsCmdTop cmd' placeHolderType placeHolderType
+                  (cmd_names `zip` cmd_names'),
                   fvCmd `plusFV` cmd_fvs) }
 
 rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
@@ -677,9 +681,9 @@ rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
   = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
         ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName
         ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName
-        ; let empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
-                                            , recS_mfix_fn = mfix_op
-                                            , recS_bind_fn = bind_op }
+        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op
+                                                , recS_mfix_fn = mfix_op
+                                                , recS_bind_fn = bind_op }
 
         -- Step1: Bring all the binders of the mdo into scope
         -- (Remember that this also removes the binders from the
index a3f34b2..aa41361 100644 (file)
@@ -205,7 +205,8 @@ matchNameMaker ctxt = LamMk report_unused
                       StmtCtxt GhciStmtCtxt -> False
                       _                     -> True
 
-rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name))
+rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName)
+           -> CpsRn (HsWithBndrs Name (LHsType Name))
 rnHsSigCps sig 
   = CpsRn (rnHsBndrSig PatCtx sig)
 
@@ -401,14 +402,16 @@ rnPatAndThen mk (AsPat rdr pat)
        ; pat' <- rnLPatAndThen mk pat
        ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
 
-rnPatAndThen mk p@(ViewPat expr pat ty)
+rnPatAndThen mk p@(ViewPat expr pat _ty)
   = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns
                       ; checkErr vp_flag (badViewPat p) }
          -- Because of the way we're arranging the recursive calls,
          -- this will be in the right context 
        ; expr' <- liftCpsFV $ rnLExpr expr 
        ; pat' <- rnLPatAndThen mk pat
-       ; return (ViewPat expr' pat' ty) }
+       -- Note: at this point the PreTcType in ty can only be a placeHolder
+       -- ; return (ViewPat expr' pat' ty) }
+       ; return (ViewPat expr' pat' placeHolderType) }
 
 rnPatAndThen mk (ConPatIn con stuff)
    -- rnConPatAndThen takes care of reconstructing the pattern
@@ -423,8 +426,9 @@ rnPatAndThen mk (ListPat pats _ _)
   = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists
        ; pats' <- rnLPatsAndThen mk pats
        ; case opt_OverloadedLists of
-          True -> do   { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
-                       ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))}
+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
+                     ; return (ListPat pats' placeHolderType
+                                       (Just (placeHolderType, to_list_name)))}
           False -> return (ListPat pats' placeHolderType Nothing) }
 
 rnPatAndThen mk (PArrPat pats _)
@@ -709,7 +713,8 @@ rnOverLit origLit
                                 HsVar v -> v /= std_name
                                 _       -> panic "rnOverLit"
         ; return (lit { ol_witness = from_thing_name
-                      , ol_rebindable = rebindable }, fvs) }
+                      , ol_rebindable = rebindable
+                      , ol_type = placeHolderType }, fvs) }
 \end{code}
 
 %************************************************************************
index a3bd38a..2dc71db 100644 (file)
@@ -515,7 +515,8 @@ rnFamInstDecl :: HsDocContext
               -> [LHsType RdrName]
               -> rhs
               -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-              -> RnM (Located Name, HsWithBndrs [LHsType Name], rhs', FreeVars)
+              -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
+                      FreeVars)
 rnFamInstDecl doc mb_cls tycon pats payload rnPayload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
index 3c0c145..c7b962e 100644 (file)
@@ -14,6 +14,7 @@ import NameSet
 import HsSyn
 import RdrName
 import TcRnMonad
+import Kind
 
 #ifdef GHCI
 import Control.Monad    ( unless, when )
@@ -46,7 +47,8 @@ rnBracket e _ = failTH e "Template Haskell bracket"
 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
 rnTopSpliceDecls e = failTH e "Template Haskell top splice"
 
-rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
+rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
+             -> RnM (HsType Name, FreeVars)
 rnSpliceType e _ = failTH e "Template Haskell type splice"
 
 rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
@@ -169,7 +171,8 @@ rnSpliceExpr is_typed splice
            ; return (unLoc lexpr3, fvs)  }
 
 ----------------------
-rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
+rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
+             -> RnM (HsType Name, FreeVars)
 rnSpliceType splice k
   = rnSpliceGen False run_type_splice pend_type_splice splice
   where
index 5f417ae..45a2a10 100644 (file)
@@ -6,8 +6,11 @@ import TcRnMonad
 import RdrName
 import Name
 import NameSet
+import Kind
 
-rnSpliceType :: HsSplice RdrName   -> PostTcKind -> RnM (HsType Name, FreeVars)
+
+rnSpliceType :: HsSplice RdrName   -> PostTc Name Kind
+             -> RnM (HsType Name, FreeVars)
 rnSplicePat  :: HsSplice RdrName   -> RnM (Pat Name, FreeVars)
 rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
 \end{code}
index 2f9bfdd..49eaa11 100644 (file)
@@ -417,8 +417,8 @@ newTyVarNameRn mb_assoc rdr_env loc rdr
 
 --------------------------------
 rnHsBndrSig :: HsDocContext
-            -> HsWithBndrs (LHsType RdrName)
-            -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars))
+            -> HsWithBndrs RdrName (LHsType RdrName)
+            -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
             -> RnM (a, FreeVars)
 rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
   = do { sig_ok <- xoptM Opt_ScopedTypeVariables
@@ -677,7 +677,8 @@ 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 [])])
+               [a11, L loc (HsCmdTop (L loc new_c)
+               placeHolderType placeHolderType [])])
         -- TODO: locs are wrong
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
index a27c0bd..de2f26a 100644 (file)
@@ -34,8 +34,8 @@ module Inst (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}  TcExpr( tcPolyExpr, tcSyntaxOp )
-import {-# SOURCE #-}  TcUnify( unifyType )
+import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
+import {-# SOURCE #-}   TcUnify( unifyType )
 
 import FastString
 import HsSyn
@@ -271,7 +271,8 @@ newOverloadedLit' dflags orig
        -- Reason: If we do, tcSimplify will call lookupInst, which
        --         will call tcSyntaxName, which does unification, 
        --         which tcSimplify doesn't like
-  = return (lit { ol_witness = expr, ol_type = res_ty })
+  = return (lit { ol_witness = expr, ol_type = res_ty
+                , ol_rebindable = rebindable })
 
   | otherwise
   = do { hs_lit <- mkOverLit val
@@ -282,7 +283,8 @@ newOverloadedLit' dflags orig
                -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
                -- However this'll be picked up by tcSyntaxOp if necessary
        ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
-       ; return (lit { ol_witness = witness, ol_type = res_ty }) }
+       ; return (lit { ol_witness = witness, ol_type = res_ty
+                      , ol_rebindable = rebindable }) }
 
 ------------
 mkOverLit :: OverLitVal -> TcM HsLit
index eab8941..a879e16 100644 (file)
@@ -381,10 +381,12 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
         ; let ret_table = zip tup_ids tup_rets
         ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
 
-        ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
-                               , recS_later_rets = later_rets
-                               , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
-                               , recS_ret_ty = res_ty }, thing)
+        ; return (emptyRecStmtId { recS_stmts = stmts'
+                                 , recS_later_ids = later_ids
+                                 , recS_later_rets = later_rets
+                                 , recS_rec_ids = rec_ids
+                                 , recS_rec_rets = rec_rets
+                                 , recS_ret_ty = res_ty }, thing)
         }}
 
 tcArrDoStmt _ _ stmt _ _
index 9db4125..6feab9e 100644 (file)
@@ -1169,7 +1169,8 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
         ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
                           , fun_matches = matches'
                           , fun_co_fn = co_fn 
-                          , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
+                          , bind_fvs = placeHolderNamesTc
+                          , fun_tick = Nothing }) }
 
 tcRhs (TcPatBind infos pat' grhss pat_ty)
   = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $
@@ -1178,7 +1179,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
                     tcGRHSsPat grhss pat_ty
         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
-                          , bind_fvs = placeHolderNames
+                          , bind_fvs = placeHolderNamesTc
                           , pat_ticks = (Nothing,[]) }) }
 
 
index 2967630..9802fb0 100644 (file)
@@ -12,6 +12,7 @@ This is where we do all the grimy bindings' generation.
 
 \begin{code}
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcGenDeriv (
         BagDerivStuff, DerivStuff(..),
@@ -1747,7 +1748,8 @@ foldDataConArgs ft con
         -- the Just will match and a::*
 
 -- Make a HsLam using a fresh variable from a State monad
-mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
+mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
+            -> State [RdrName] (LHsExpr RdrName)
 -- (mkSimpleLam fn) returns (\x. fn(x))
 mkSimpleLam lam = do
     (n:names) <- get
@@ -1755,7 +1757,9 @@ mkSimpleLam lam = do
     body <- lam (nlHsVar n)
     return (mkHsLam [nlVarPat n] body)
 
-mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
+mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
+             -> State [RdrName] (LHsExpr RdrName))
+             -> State [RdrName] (LHsExpr RdrName)
 mkSimpleLam2 lam = do
     (n1:n2:names) <- get
     put names
index d4c3934..acdd654 100644 (file)
@@ -7,7 +7,7 @@ The deriving code for the Generic class
 
 \begin{code}
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
-
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       GenericKind(..),
index 39c0acf..c4ed2a6 100644 (file)
@@ -14,7 +14,7 @@
 -- for details
 
 module TcHsType (
-       tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, 
+       tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst,
        tcHsInstHead, 
        UserTypeCtxt(..), 
 
@@ -1233,8 +1233,8 @@ Historical note:
 
 \begin{code}
 tcHsPatSigType :: UserTypeCtxt
-              -> HsWithBndrs (LHsType Name)  -- The type signature
-             -> TcM ( Type                   -- The signature
+              -> HsWithBndrs Name (LHsType Name) -- The type signature
+             -> TcM ( Type                       -- The signature
                       , [(Name, TcTyVar)] )   -- The new bit of type environment, binding
                                              -- the scoped type variables
 -- Used for type-checking type signatures in
@@ -1263,7 +1263,7 @@ tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig
           _              -> newSigTyVar name kind  -- See Note [Unifying SigTvs]
 
 tcPatSig :: UserTypeCtxt
-        -> HsWithBndrs (LHsType Name)
+        -> HsWithBndrs Name (LHsType Name)
         -> TcSigmaType
         -> TcM (TcType,            -- The type to use for "inside" the signature
                 [(Name, TcTyVar)], -- The new bit of type environment, binding
index b5fbc29..6ae3ba0 100644 (file)
@@ -215,7 +215,7 @@ tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_arg
                       , fun_infix = False
                       , fun_matches = mg
                       , fun_co_fn = idHsWrapper
-                      , bind_fvs = placeHolderNames
+                      , bind_fvs = placeHolderNamesTc
                       , fun_tick = Nothing }}
   where
     args = map unLoc $ case details of
index cd27e9d..9898b46 100644 (file)
@@ -1385,7 +1385,8 @@ tcUserStmt rdr_stmt@(L loc _)
            ; return stuff }
       where
         print_v  = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
-                                    (HsVar thenIOName) noSyntaxExpr placeHolderType
+                                    (HsVar thenIOName) noSyntaxExpr
+                                    placeHolderType
 
 -- | Typecheck the statements given and then return the results of the
 -- statement in the form 'IO [()]'.
index 6dcbaff..3c6aedb 100644 (file)
@@ -996,9 +996,9 @@ famTyConShape fam_tc
     , tyConKind fam_tc )
 
 tc_fam_ty_pats :: FamTyConShape
-               -> HsWithBndrs [LHsType Name] -- Patterns
-               -> (TcKind -> TcM ())         -- Kind checker for RHS
-                                             -- result is ignored
+               -> HsWithBndrs Name [LHsType Name] -- Patterns
+               -> (TcKind -> TcM ())              -- Kind checker for RHS
+                                                  -- result is ignored
                -> TcM ([Kind], [Type], Kind)
 -- Check the type patterns of a type or data family instance
 --     type instance F <pat1> <pat2> = <type>
@@ -1045,8 +1045,8 @@ tc_fam_ty_pats (name, arity, kind)
 
 -- See Note [tc_fam_ty_pats vs tcFamTyPats]
 tcFamTyPats :: FamTyConShape
-            -> HsWithBndrs [LHsType Name] -- patterns
-            -> (TcKind -> TcM ())         -- kind-checker for RHS
+            -> HsWithBndrs Name [LHsType Name] -- patterns
+            -> (TcKind -> TcM ())              -- kind-checker for RHS
             -> ([TKVar]              -- Kind and type variables
                 -> [TcType]          -- Kind and type arguments
                 -> Kind -> TcM a)
diff --git a/testsuite/tests/ghc-api/landmines/.gitignore b/testsuite/tests/ghc-api/landmines/.gitignore
new file mode 100644 (file)
index 0000000..1452e78
--- /dev/null
@@ -0,0 +1,5 @@
+landmines
+*.hi
+*.o
+*.run.*
+*.normalised
diff --git a/testsuite/tests/ghc-api/landmines/Makefile b/testsuite/tests/ghc-api/landmines/Makefile
new file mode 100644 (file)
index 0000000..3197647
--- /dev/null
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+       rm -f *.o *.hi
+
+landmines: clean
+       '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc landmines
+       ./landmines "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+
+.PHONY: clean
diff --git a/testsuite/tests/ghc-api/landmines/MineFixity.hs b/testsuite/tests/ghc-api/landmines/MineFixity.hs
new file mode 100644 (file)
index 0000000..a735ee6
--- /dev/null
@@ -0,0 +1,23 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-
+
+Exercising avoidance of known landmines.
+
+We need one each of
+
+  PostTc id Kind
+  PostTc id Type
+
+  PostRn id Fixity
+  PostRn id NameSet
+
+
+-}
+module MineFixity where
+
+infixl 3 `foo`
+
+foo = undefined
diff --git a/testsuite/tests/ghc-api/landmines/MineKind.hs b/testsuite/tests/ghc-api/landmines/MineKind.hs
new file mode 100644 (file)
index 0000000..c97a996
--- /dev/null
@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-
+
+Exercising avoidance of known landmines.
+
+We need one each of
+
+  PostTc id Kind
+  PostTc id Type
+
+  PostRn id Fixity
+  PostRn id NameSet
+
+
+-}
+module MineKind where
+
+data HList :: [*] -> * where
+  HNil  :: HList '[]
+  HCons :: a -> HList t -> HList (a ': t)
+
+data Tuple :: (*,*) -> * where
+  Tuple :: a -> b -> Tuple '(a,b)
diff --git a/testsuite/tests/ghc-api/landmines/MineNames.hs b/testsuite/tests/ghc-api/landmines/MineNames.hs
new file mode 100644 (file)
index 0000000..af5362f
--- /dev/null
@@ -0,0 +1,22 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-
+
+Exercising avoidance of known landmines.
+
+We need one each of
+
+  PostTc id Kind
+  PostTc id Type
+
+  PostRn id Fixity
+  PostRn id NameSet
+
+
+-}
+module MineNames where
+
+foo :: Int
+foo = 1
diff --git a/testsuite/tests/ghc-api/landmines/MineType.hs b/testsuite/tests/ghc-api/landmines/MineType.hs
new file mode 100644 (file)
index 0000000..142d7c9
--- /dev/null
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-
+
+Exercising avoidance of known landmines.
+
+We need one each of
+
+  PostTc id Kind
+  PostTc id Type
+
+  PostRn id Fixity
+  PostRn id NameSet
+
+
+-}
+module MineType where
+
+foo = undefined
diff --git a/testsuite/tests/ghc-api/landmines/all.T b/testsuite/tests/ghc-api/landmines/all.T
new file mode 100644 (file)
index 0000000..b03a97f
--- /dev/null
@@ -0,0 +1,2 @@
+test('landmines', normal, run_command, ['$MAKE -s --no-print-directory landmines'])
+
diff --git a/testsuite/tests/ghc-api/landmines/landmines.hs b/testsuite/tests/ghc-api/landmines/landmines.hs
new file mode 100644 (file)
index 0000000..9b058fa
--- /dev/null
@@ -0,0 +1,90 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import System.IO
+import GHC
+import MonadUtils
+import Outputable
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+
+main::IO()
+main = do
+        [libdir] <- getArgs
+        testOneFile libdir "MineFixity"
+        testOneFile libdir "MineKind"
+        testOneFile libdir "MineNames"
+        testOneFile libdir "MineType"
+
+
+testOneFile libdir fileName = do
+        (p,r,ts) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        t <- typecheckModule p
+                        d <- desugarModule t
+                        l <- loadModule d
+                        let ts=typecheckedSource l
+                            r =renamedSource l
+                        -- liftIO (putStr (showSDocDebug (ppr ts)))
+                        return (pm_parsed_source p,r,ts)
+        let pCount = gq p
+            rCount = gq r
+            tsCount = gq ts
+
+        print (pCount,rCount,tsCount)
+    where
+        gq ast = length $ everything (++)    ([] `mkQ` worker) ast
+
+        worker (s@(RealSrcSpan _)) = [s]
+        worker _ = []
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout
new file mode 100644 (file)
index 0000000..5d9fd71
--- /dev/null
@@ -0,0 +1,4 @@
+(9,9,6)
+(46,42,0)
+(11,10,6)
+(7,7,6)
index eee52f6..aacaa91 160000 (submodule)
@@ -1 +1 @@
-Subproject commit eee52f697233f99e23c1d8183511229fb93e3f3e
+Subproject commit aacaa91951b16f22e3ad54412974b81c32230a8c