never executed always true always false

    1 
    2 -- (those who have too heavy dependencies for GHC.Tc.Types.Evidence)
    3 module GHC.Tc.Types.EvTerm
    4     ( evDelayedError, evCallStack )
    5 where
    6 
    7 import GHC.Prelude
    8 
    9 import GHC.Driver.Session
   10 
   11 import GHC.Tc.Types.Evidence
   12 
   13 import GHC.Unit
   14 
   15 import GHC.Builtin.Names
   16 import GHC.Builtin.Types ( unitTy )
   17 
   18 import GHC.Core.Type
   19 import GHC.Core
   20 import GHC.Core.Make
   21 import GHC.Core.Utils
   22 
   23 import GHC.Types.SrcLoc
   24 import GHC.Types.TyThing
   25 
   26 -- Used with Opt_DeferTypeErrors
   27 -- See Note [Deferring coercion errors to runtime]
   28 -- in GHC.Tc.Solver
   29 evDelayedError :: Type -> String -> EvTerm
   30 evDelayedError ty msg
   31   = EvExpr $
   32     let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg
   33     in mkWildCase fail_expr (unrestricted unitTy) ty []
   34        -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils
   35        -- c.f. mkErrorAppDs in GHC.HsToCore.Utils
   36 
   37 -- Dictionary for CallStack implicit parameters
   38 evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
   39     EvCallStack -> m EvExpr
   40 -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
   41 evCallStack cs = do
   42   df            <- getDynFlags
   43   let platform = targetPlatform df
   44   m             <- getModule
   45   srcLocDataCon <- lookupDataCon srcLocDataConName
   46   let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
   47                sequence [ mkStringExprFS (unitFS $ moduleUnit m)
   48                         , mkStringExprFS (moduleNameFS $ moduleName m)
   49                         , mkStringExprFS (srcSpanFile l)
   50                         , return $ mkIntExprInt platform (srcSpanStartLine l)
   51                         , return $ mkIntExprInt platform (srcSpanStartCol l)
   52                         , return $ mkIntExprInt platform (srcSpanEndLine l)
   53                         , return $ mkIntExprInt platform (srcSpanEndCol l)
   54                         ]
   55 
   56   emptyCS <- Var <$> lookupId emptyCallStackName
   57 
   58   pushCSVar <- lookupId pushCallStackName
   59   let pushCS name loc rest =
   60         mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
   61 
   62   let mkPush name loc tm = do
   63         nameExpr <- mkStringExprFS name
   64         locExpr <- mkSrcLoc loc
   65         -- at this point tm :: IP sym CallStack
   66         -- but we need the actual CallStack to pass to pushCS,
   67         -- so we use unwrapIP to strip the dictionary wrapper
   68         -- See Note [Overview of implicit CallStacks]
   69         let ip_co = unwrapIP (exprType tm)
   70         return (pushCS nameExpr locExpr (Cast tm ip_co))
   71 
   72   case cs of
   73     EvCsPushCall fs loc tm -> mkPush fs loc tm
   74     EvCsEmpty              -> return emptyCS