Commit 658e99a8 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Recover gracefully from a Template Haskell programmers error

If a TH programmer uses a type constructor as a data constructor,
GHC simply crashed.  This commit makes it report the error in a
graceful way.
parent 284e6b50
...@@ -201,11 +201,9 @@ isExact_maybe other = Nothing ...@@ -201,11 +201,9 @@ isExact_maybe other = Nothing
\begin{code} \begin{code}
instance Outputable RdrName where instance Outputable RdrName where
ppr (Exact name) = ppr name ppr (Exact name) = ppr name
ppr (Unqual occ) = ppr occ <+> ppr_name_space occ ppr (Unqual occ) = ppr occ
ppr (Qual mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
ppr (Orig mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ ppr (Orig mod occ) = ppr mod <> dot <> ppr occ
ppr_name_space occ = ifPprDebug (parens (pprNonVarNameSpace (occNameSpace occ)))
instance OutputableBndr RdrName where instance OutputableBndr RdrName where
pprBndr _ n pprBndr _ n
......
...@@ -11,7 +11,7 @@ module TcEnv( ...@@ -11,7 +11,7 @@ module TcEnv(
tcExtendGlobalEnv, tcExtendGlobalEnv,
tcExtendGlobalValEnv, tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal, tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupLocatedClass,
...@@ -121,16 +121,19 @@ tcLookupGlobal name ...@@ -121,16 +121,19 @@ tcLookupGlobal name
tcImportDecl name -- Go find it in an interface tcImportDecl name -- Go find it in an interface
}}}}} }}}}}
tcLookupGlobalId :: Name -> TcM Id tcLookupField :: Name -> TcM Id -- Returns the selector Id
-- Never used for Haskell-source DataCons, hence no ADataCon case tcLookupField name
tcLookupGlobalId name
= tcLookupGlobal name `thenM` \ thing -> = tcLookupGlobal name `thenM` \ thing ->
return (tyThingId thing) case thing of
AnId id -> return id
other -> wrongThingErr "field name" (AGlobal thing) name
tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name tcLookupDataCon name
= tcLookupGlobal con_name `thenM` \ thing -> = tcLookupGlobal name `thenM` \ thing ->
return (tyThingDataCon thing) case thing of
ADataCon con -> return con
other -> wrongThingErr "data constructor" (AGlobal thing) name
tcLookupClass :: Name -> TcM Class tcLookupClass :: Name -> TcM Class
tcLookupClass name tcLookupClass name
......
...@@ -32,9 +32,7 @@ import BasicTypes ( Arity, isMarkedStrict ) ...@@ -32,9 +32,7 @@ import BasicTypes ( Arity, isMarkedStrict )
import Inst ( newMethodFromName, newIPDict, instToId, import Inst ( newMethodFromName, newIPDict, instToId,
newDicts, newMethodWithGivenTy, tcInstStupidTheta ) newDicts, newMethodWithGivenTy, tcInstStupidTheta )
import TcBinds ( tcLocalBinds ) import TcBinds ( tcLocalBinds )
import TcEnv ( tcLookup, tcLookupId, import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupField )
tcLookupDataCon, tcLookupGlobalId
)
import TcArrows ( tcProc ) import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
...@@ -394,7 +392,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty ...@@ -394,7 +392,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
let let
field_names = map fst rbinds field_names = map fst rbinds
in in
mappM (tcLookupGlobalId.unLoc) field_names `thenM` \ sel_ids -> mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids ->
-- The renamer has already checked that they -- The renamer has already checked that they
-- are all in scope -- are all in scope
let let
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment