├── README.org ├── cabal.project ├── plugin ├── AssertExplainer.hs ├── Constraint.hs ├── Explain.hs ├── HERMIT │ └── GHC │ │ └── TypeChecker.hs └── plugin.cabal └── test ├── Test.hs └── test.cabal /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Assert Explainer (or: can we have py.test in Haskell?) 2 | 3 | Assert Explainer is a library & GHC source plugin to help writing assertions. In 4 | particular, it is to help you understand *why* an assertion has failed. 5 | 6 | How many times have you written some kind of unit test assertion like 7 | 8 | #+BEGIN_SRC haskell 9 | assert (length xs == 4) 10 | #+END_SRC 11 | 12 | And got: 13 | 14 | #+BEGIN_SRC 15 | exception: Assertion failed! 16 | #+END_SRC 17 | 18 | This sucks! Why did the assertion fail? When things have gone wrong, it's too late to find out way - the information has gone. 19 | 20 | With AssertExplainer, you simply write =Bool=-valued expressions, and 21 | the plugin will take care of the rest. 22 | 23 | First: 24 | 25 | #+BEGIN_SRC haskell 26 | {-# OPTIONS -fplugin=AssertExplainer #-} 27 | #+END_SRC 28 | 29 | Then write your assertion. The above would be simply: 30 | 31 | #+BEGIN_SRC haskell 32 | assert (length xs == 4) 33 | #+END_SRC 34 | 35 | No need for lots of special =assertEqual= etc functions. 36 | 37 | When the assertion fails, you will get much more context: 38 | 39 | #+BEGIN_SRC 40 | ✘ Assertion failed! 41 | length xs == 4 /= True (at Test.hs:18:12-25) 42 | 43 | I found the following sub-expressions: 44 | - length xs = 3 45 | - xs = [1,2,3] 46 | #+END_SRC 47 | 48 | Ultimately, my goal is to write something more akin to 49 | [[https://docs.pytest.org/en/latest/example/reportingdemo.html#tbreportdemo][py.test's assertion magic]]. This is just a proof of concept right now, 50 | but maybe we'll get there! 51 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./plugin 2 | ./test 3 | -------------------------------------------------------------------------------- /plugin/AssertExplainer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module AssertExplainer ( plugin, assert ) where 6 | 7 | -- assert-explainer 8 | import qualified Constraint 9 | 10 | -- base 11 | import GHC.Stack ( HasCallStack, callStack, prettyCallStack ) 12 | import Data.Bool ( bool ) 13 | import Data.List ( foldl' ) 14 | import Control.Monad ( guard ) 15 | import Control.Monad.IO.Class ( liftIO ) 16 | import Data.Foldable ( toList ) 17 | import Data.Maybe ( catMaybes ) 18 | 19 | -- ghc 20 | import qualified Convert as GHC 21 | import qualified CoreUtils 22 | import qualified Desugar as GHC 23 | import qualified Finder as GHC 24 | import qualified GHC 25 | import qualified GhcPlugins as GHC 26 | import qualified HsExpr as Expr 27 | import qualified IfaceEnv as GHC 28 | import qualified PrelNames as GHC 29 | import qualified RnExpr as GHC 30 | import qualified TcEnv as GHC 31 | import qualified TcEvidence as GHC 32 | import qualified TcExpr as GHC 33 | import qualified TcHsSyn as GHC 34 | import qualified TcRnMonad as GHC 35 | import qualified TcSimplify as GHC 36 | import qualified TcType as GHC 37 | 38 | -- prettyprinter 39 | import qualified Data.Text.Prettyprint.Doc as PP 40 | import qualified Data.Text.Prettyprint.Doc.Render.Text as PP 41 | 42 | -- syb 43 | import Data.Generics ( everywhereM, listify, mkM ) 44 | 45 | -- template-haskell 46 | import Language.Haskell.TH as TH 47 | 48 | 49 | {-| 50 | 51 | The @assert-explainer@ plugin intercepts calls to 'assert' and tries to explain 52 | them if they fail. You can use this plugin by depending on the 53 | @assert-explainer@ library, and then adding: 54 | 55 | @{-# OPTIONS -fplugin=AssertExplainer #-}@ 56 | 57 | to your test pragmas. 58 | -} 59 | 60 | plugin :: GHC.Plugin 61 | plugin = 62 | GHC.defaultPlugin 63 | { GHC.typeCheckResultAction = \_cliOptions -> explainAssertions } 64 | 65 | 66 | explainAssertions :: GHC.ModSummary -> GHC.TcGblEnv -> GHC.TcM GHC.TcGblEnv 67 | explainAssertions _modSummary tcGblEnv = do 68 | hscEnv <- 69 | GHC.getTopEnv 70 | 71 | GHC.Found _ assertExplainerModule <- 72 | liftIO 73 | ( GHC.findImportedModule 74 | hscEnv 75 | ( GHC.mkModuleName "AssertExplainer" ) 76 | Nothing 77 | ) 78 | 79 | assertName <- 80 | GHC.lookupId 81 | =<< GHC.lookupOrig assertExplainerModule ( GHC.mkVarOcc "assert" ) 82 | 83 | tcg_binds <- 84 | mkM ( rewriteAssert assertName ) `everywhereM` GHC.tcg_binds tcGblEnv 85 | 86 | return tcGblEnv { GHC.tcg_binds = tcg_binds } 87 | 88 | 89 | assert :: HasCallStack => Bool -> IO () 90 | assert = 91 | bool 92 | ( putStrLn ( "Assertion failed! " <> prettyCallStack callStack ) ) 93 | ( return () ) 94 | 95 | 96 | -- | Rewrite an 'assert' call into further analysis on the expression being asserted. 97 | rewriteAssert :: GHC.Id -> Expr.LHsExpr GHC.GhcTc -> GHC.TcM ( Expr.LHsExpr GHC.GhcTc ) 98 | rewriteAssert assertName ( GHC.L _ ( Expr.HsApp _ ( GHC.L _ ( Expr.HsWrap _ _ ( Expr.HsVar _ ( GHC.L _ v ) ) ) ) body ) ) | assertName == v = do 99 | explain body 100 | rewriteAssert _ e = 101 | return e 102 | 103 | 104 | data Typed = Typed 105 | { typedExpr :: Expr.LHsExpr GHC.GhcTcId 106 | , typedExprType :: GHC.Type 107 | } 108 | 109 | 110 | explain :: Expr.LHsExpr GHC.GhcTc -> GHC.TcM ( Expr.LHsExpr GHC.GhcTc ) 111 | explain toExplain = do 112 | -- Find all sub-expressions in the body 113 | let 114 | subExpressions = 115 | listify isInterestingSubexpr toExplain 116 | 117 | -- Augment each sub-expression with its type 118 | typedSubExpressions <- 119 | catMaybes <$> traverse toTyped subExpressions 120 | 121 | -- Filter the list of sub-expressions to just those that can be shown. 122 | given:showableSubExpresions <- 123 | catMaybes <$> traverse witnessShow typedSubExpressions 124 | 125 | -- Build an anonymous function to describe all of these subexpressions 126 | Right expr <- 127 | fmap ( GHC.convertToHsExpr GHC.noSrcSpan ) 128 | $ liftIO 129 | $ TH.runQ 130 | $ do 131 | diagnosticArgs <- 132 | sequence ( TH.newName "x" <$ showableSubExpresions ) 133 | 134 | let 135 | diagnose te name = 136 | TH.noBindS ( diagnoseExpr te name ) 137 | 138 | diagnosed = 139 | case zipWith diagnose showableSubExpresions diagnosticArgs of 140 | [] -> 141 | [] 142 | 143 | diags -> 144 | [ TH.noBindS 145 | ( TH.doE 146 | ( TH.noBindS 147 | [| putStrLn "" 148 | >> putStrLn " I found the following sub-expressions:" 149 | |] 150 | : diags 151 | ) 152 | ) 153 | ] 154 | 155 | topName <- 156 | TH.newName "x" 157 | 158 | TH.lam1E 159 | ( TH.varP topName ) 160 | ( foldl' 161 | ( \e name -> TH.lam1E ( TH.varP name ) e ) 162 | ( TH.condE 163 | ( TH.varE topName ) 164 | ( assertionOk given ) 165 | ( TH.doE ( assertionFailed given : diagnosed ) ) 166 | ) 167 | ( reverse diagnosticArgs ) 168 | ) 169 | 170 | -- Rename the Template Haskell source 171 | ( diagnosticFunction, _ ) <- 172 | GHC.rnLExpr expr 173 | 174 | -- Build the type of the diagnostic function... 175 | diagnosticFunctionT <- do 176 | io <- 177 | GHC.lookupTyCon ( GHC.ioTyConName ) 178 | 179 | return 180 | ( foldr 181 | GHC.mkFunTy 182 | ( GHC.mkTyConApp io [ GHC.mkTyConTy GHC.unitTyCon ] ) 183 | ( map 184 | typedExprType 185 | ( given : showableSubExpresions ) 186 | ) 187 | ) 188 | 189 | -- Type check our diagnostic function to find which dictionaries need to be 190 | -- resolved. 191 | ( ifExpr', wanteds ) <- 192 | GHC.captureConstraints 193 | ( GHC.tcMonoExpr 194 | diagnosticFunction 195 | ( GHC.Check diagnosticFunctionT ) 196 | ) 197 | 198 | -- Solve wanted constraints and build a wrapper. 199 | wrapper <- 200 | GHC.mkWpLet . GHC.EvBinds <$> GHC.simplifyTop wanteds 201 | 202 | -- Apply the wrapper to our type checked syntax and fully saturate the 203 | -- diagnostic function with the necessary arguments. 204 | GHC.zonkTopLExpr 205 | ( foldl 206 | GHC.mkHsApp 207 | ( GHC.mkLHsWrap wrapper ifExpr' ) 208 | ( map 209 | typedExpr 210 | ( given : showableSubExpresions ) 211 | ) 212 | ) 213 | 214 | 215 | diagnoseExpr :: Typed -> TH.Name -> TH.ExpQ 216 | diagnoseExpr te name = 217 | let 218 | ppExpr = 219 | GHC.renderWithStyle 220 | GHC.unsafeGlobalDynFlags 221 | ( GHC.ppr ( typedExpr te ) ) 222 | ( GHC.defaultUserStyle GHC.unsafeGlobalDynFlags ) 223 | in 224 | [| PP.putDoc 225 | ( PP.indent 226 | 4 227 | ( PP.pretty "-" 228 | PP.<+> PP.pretty ppExpr 229 | PP.<+> PP.equals 230 | PP.<+> PP.pretty ( show $( TH.varE name ) ) 231 | ) 232 | <> PP.line 233 | ) 234 | |] 235 | 236 | 237 | assertionFailed :: Typed -> TH.StmtQ 238 | assertionFailed te = 239 | let 240 | ppExpr = 241 | GHC.renderWithStyle 242 | GHC.unsafeGlobalDynFlags 243 | ( GHC.ppr ( typedExpr te ) ) 244 | ( GHC.defaultUserStyle GHC.unsafeGlobalDynFlags ) 245 | 246 | srcLoc = 247 | GHC.renderWithStyle 248 | GHC.unsafeGlobalDynFlags 249 | ( GHC.ppr ( case typedExpr te of GHC.L l _ -> l ) ) 250 | ( GHC.defaultUserStyle GHC.unsafeGlobalDynFlags ) 251 | 252 | in 253 | TH.noBindS 254 | [| do 255 | putStrLn ( "✘ Assertion failed!\n " <> ppExpr <> " /= True (at " <> srcLoc <> ")" ) 256 | |] 257 | 258 | 259 | assertionOk :: Typed -> TH.ExpQ 260 | assertionOk te = 261 | let 262 | ppExpr = 263 | GHC.renderWithStyle 264 | GHC.unsafeGlobalDynFlags 265 | ( GHC.ppr ( typedExpr te ) ) 266 | ( GHC.defaultUserStyle GHC.unsafeGlobalDynFlags ) 267 | 268 | srcLoc = 269 | GHC.renderWithStyle 270 | GHC.unsafeGlobalDynFlags 271 | ( GHC.ppr ( case typedExpr te of GHC.L l _ -> l ) ) 272 | ( GHC.defaultUserStyle GHC.unsafeGlobalDynFlags ) 273 | 274 | in 275 | [| putStrLn ( "✔ " <> ppExpr <> " == True (at " <> srcLoc <> ")" ) 276 | |] 277 | 278 | 279 | isInterestingSubexpr :: Expr.LHsExpr GHC.GhcTc -> Bool 280 | isInterestingSubexpr ( GHC.L _ Expr.HsPar{} ) = 281 | False 282 | isInterestingSubexpr ( GHC.L _ Expr.HsLit{}) = 283 | False 284 | isInterestingSubexpr ( GHC.L _ Expr.HsOverLit{} ) = 285 | False 286 | isInterestingSubexpr ( GHC.L _ Expr.HsWrap{} ) = 287 | False 288 | isInterestingSubexpr _ = 289 | True 290 | 291 | 292 | -- | Given a type-checked expression, pair the expression up with its Type. 293 | toTyped :: Expr.LHsExpr GHC.GhcTc -> GHC.TcM ( Maybe Typed ) 294 | toTyped e = do 295 | hs_env <- 296 | GHC.getTopEnv 297 | 298 | ( _, mbe ) <- 299 | liftIO ( GHC.deSugarExpr hs_env e ) 300 | 301 | return ( ( \x -> Typed e ( CoreUtils.exprType x ) ) <$> mbe ) 302 | 303 | 304 | -- | Given a typed expression, ensure that it has a Show instance. 305 | witnessShow :: Typed -> GHC.TcM ( Maybe Typed ) 306 | witnessShow tExpr = do 307 | showTyCon <- 308 | GHC.tcLookupTyCon GHC.showClassName 309 | 310 | dictName <- 311 | GHC.newName ( GHC.mkDictOcc ( GHC.mkVarOcc "magic" ) ) 312 | 313 | let 314 | dict_ty = 315 | GHC.mkTyConApp showTyCon [ typedExprType tExpr ] 316 | 317 | dict_var = 318 | GHC.mkVanillaGlobal dictName dict_ty 319 | 320 | GHC.EvBinds evBinds <- 321 | Constraint.getDictionaryBindings dict_var dict_ty 322 | 323 | return ( tExpr <$ guard ( not ( null ( toList evBinds ) ) ) ) 324 | -------------------------------------------------------------------------------- /plugin/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | 5 | module Constraint where 6 | 7 | import GhcPlugins 8 | import TcRnTypes 9 | import HsExpr 10 | import HsBinds 11 | import HsExtension 12 | import PrelNames 13 | import ConLike 14 | 15 | import TcRnMonad 16 | import TcEnv 17 | import Unique 18 | import Control.Arrow 19 | import TcEvidence 20 | import TcSMonad 21 | import TcSimplify 22 | import DsBinds 23 | import Bag 24 | 25 | import Generics.SYB hiding (empty) 26 | 27 | 28 | generateDictionary :: TcM TcEvBinds 29 | generateDictionary = do 30 | showTyCon <- tcLookupTyCon showClassName 31 | dictName <- newName (mkDictOcc (mkVarOcc "magic")) 32 | let dict_ty = (mkTyConApp showTyCon [ unitTy ]) 33 | dict_var = mkVanillaGlobal dictName dict_ty 34 | getDictionaryBindings dict_var dict_ty 35 | 36 | 37 | -- Pass in "Show ()" for example 38 | getDictionaryBindings :: Var -> Type -> TcM TcEvBinds 39 | getDictionaryBindings dict_var dictTy = do 40 | 41 | loc <- getCtLocM (GivenOrigin UnkSkol) Nothing 42 | let nonC = mkNonCanonical CtWanted 43 | { ctev_pred = varType dict_var 44 | , ctev_nosh = WDeriv 45 | , ctev_dest = EvVarDest dict_var 46 | , ctev_loc = loc 47 | } 48 | wCs = mkSimpleWC [cc_ev nonC] 49 | (_, evBinds) <- second evBindMapBinds <$> runTcS (solveWanteds wCs) 50 | return (EvBinds evBinds) 51 | 52 | 53 | install :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv 54 | install _ _ tc_gbl = do 55 | let binds = tcg_binds tc_gbl 56 | let res = checkBinds binds 57 | generateDictionary 58 | return tc_gbl 59 | 60 | checkBinds :: LHsBinds GhcTc -> [LHsExpr GhcTc] 61 | checkBinds lhs_binds = 62 | listify checkCoerce lhs_binds 63 | 64 | castExpr :: Typeable r => r -> Maybe (LHsExpr GhcTc) 65 | castExpr = cast 66 | 67 | checkCoerce :: Typeable r => r -> Bool 68 | checkCoerce r = 69 | case castExpr r of 70 | Just b -> checkExpr b 71 | Nothing -> False 72 | 73 | ignoreWrapper :: LHsExpr GhcTc -> HsExpr GhcTc 74 | ignoreWrapper (L _ (HsWrap _ _ e)) = e 75 | ignoreWrapper w = unLoc w 76 | 77 | pattern CL :: DataCon -> LHsExpr GhcTc 78 | pattern CL dc <- (ignoreWrapper -> HsConLikeOut _ (RealDataCon dc)) 79 | 80 | pattern MapApp :: IdP GhcTc -> DataCon -> LHsExpr GhcTc 81 | pattern MapApp var r <- (ignoreWrapper -> (HsApp _ ((ignoreWrapper -> (HsVar _ (L _ var)))) 82 | (((CL r))))) 83 | 84 | checkExpr :: LHsExpr GhcTc -> Bool 85 | checkExpr (MapApp var dc) 86 | | (getName var) == mapName 87 | , isNewTyCon (dataConTyCon dc) 88 | = True 89 | checkExpr _ = False 90 | -------------------------------------------------------------------------------- /plugin/Explain.hs: -------------------------------------------------------------------------------- 1 | module Explain (explainShow) where 2 | 3 | explainShow :: Show a => String -> a -> String 4 | explainShow name a = name ++ " = " ++ show a 5 | -------------------------------------------------------------------------------- /plugin/HERMIT/GHC/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module HERMIT.GHC.TypeChecker 5 | ( 6 | initTcFromModGuts 7 | , mk_type_env 8 | , tcLookupGlobal 9 | ) where 10 | 11 | import Annotations (emptyAnnEnv) 12 | import HsSyn 13 | import RdrName 14 | import TcRnMonad 15 | import CoreSyn 16 | import ErrUtils 17 | import VarEnv 18 | import Name 19 | import NameEnv 20 | import NameSet 21 | import SrcLoc 22 | import HscTypes 23 | import Outputable 24 | import Data.IORef ( newIORef, readIORef ) 25 | 26 | import TcEnv ( tcLookupGlobal ) 27 | import DynFlags ( getSigOf ) 28 | #if __GLASGOW_HASKELL__ > 710 29 | import Module ( moduleName ) 30 | #else 31 | import Module ( mkModuleSet, moduleName ) 32 | #endif 33 | import TcType ( topTcLevel ) 34 | 35 | import FastString 36 | import Bag 37 | 38 | #if __GLASGOW_HASKELL__ <= 710 39 | import qualified Data.Set as Set 40 | #endif 41 | import qualified Data.Map as Map 42 | 43 | import Prelude hiding (mod) 44 | import VarSet (emptyVarSet) 45 | 46 | -- Note: the contents of this module should eventually be folded into GHC proper. 47 | 48 | -- | Re-Setup the typechecking environment from a ModGuts 49 | initTcFromModGuts 50 | :: HscEnv 51 | -> ModGuts 52 | -> HscSource 53 | -> Bool -- True <=> retain renamed syntax trees 54 | -> TcM r 55 | -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside 56 | -- (error messages should have been printed already) 57 | initTcFromModGuts hsc_env guts hsc_src keep_rn_syntax do_this 58 | = do { let { type_env = mk_type_env guts } ; 59 | errs_var <- newIORef (emptyBag, emptyBag) ; 60 | tvs_var <- newIORef emptyVarSet ; 61 | keep_var <- newIORef emptyNameSet ; 62 | #if __GLASGOW_HASKELL__ > 710 63 | used_gre_var <- newIORef [] ; 64 | #else 65 | used_rdr_var <- newIORef Set.empty ; 66 | #endif 67 | th_var <- newIORef False ; 68 | th_splice_var<- newIORef False ; 69 | #if __GLASGOW_HASKELL__ > 710 70 | infer_var <- newIORef (True, emptyBag) ; 71 | #else 72 | infer_var <- newIORef True ; 73 | #endif 74 | lie_var <- newIORef emptyWC ; 75 | dfun_n_var <- newIORef (mk_dfun_n guts) ; 76 | type_env_var <- newIORef type_env ; 77 | 78 | dependent_files_var <- newIORef [] ; 79 | static_wc_var <- newIORef emptyWC ; 80 | 81 | th_topdecls_var <- newIORef [] ; 82 | th_topnames_var <- newIORef emptyNameSet ; 83 | th_modfinalizers_var <- newIORef [] ; 84 | th_state_var <- newIORef Map.empty ; 85 | #if __GLASGOW_HASKELL__ > 710 86 | th_remote_state_var <- newIORef Nothing ; 87 | #endif 88 | 89 | let { 90 | dflags = hsc_dflags hsc_env ; 91 | mod = mg_module guts ; 92 | 93 | maybe_rn_syntax :: forall a. a -> Maybe a ; 94 | maybe_rn_syntax empty_val 95 | | keep_rn_syntax = Just empty_val 96 | | otherwise = Nothing ; 97 | 98 | gbl_env = TcGblEnv { 99 | -- these first four are CPP'd in GHC itself, but we include them here 100 | tcg_th_topdecls = th_topdecls_var, 101 | tcg_th_topnames = th_topnames_var, 102 | tcg_th_modfinalizers = th_modfinalizers_var, 103 | tcg_th_state = th_state_var, 104 | 105 | -- queried during tcrnif 106 | tcg_mod = mod, 107 | tcg_src = hsc_src, 108 | tcg_sig_of = getSigOf dflags (moduleName mod), 109 | tcg_impl_rdr_env = Nothing, 110 | tcg_rdr_env = mg_rdr_env guts, 111 | tcg_default = Nothing, 112 | tcg_fix_env = mg_fix_env guts, 113 | tcg_field_env = mk_field_env guts, 114 | tcg_type_env = type_env, 115 | tcg_type_env_var = type_env_var, 116 | tcg_inst_env = mg_inst_env guts, 117 | tcg_fam_inst_env = mg_fam_inst_env guts, 118 | tcg_ann_env = emptyAnnEnv, 119 | #if __GLASGOW_HASKELL__ <= 710 120 | tcg_visible_orphan_mods = mkModuleSet [mod], 121 | #endif 122 | tcg_dfun_n = dfun_n_var, 123 | 124 | -- accumulated, not queried, during tcrnif 125 | tcg_dependent_files = dependent_files_var, 126 | tcg_tc_plugins = [], 127 | tcg_static_wc = static_wc_var, 128 | tcg_exports = [], 129 | tcg_warns = NoWarnings, 130 | tcg_anns = [], 131 | tcg_tcs = [], 132 | tcg_insts = [], 133 | tcg_fam_insts = [], 134 | tcg_rules = [], 135 | tcg_th_used = th_var, 136 | tcg_imports = emptyImportAvails, 137 | tcg_dus = emptyDUs, 138 | tcg_ev_binds = emptyBag, 139 | tcg_fords = [], 140 | tcg_vects = [], 141 | tcg_patsyns = [], 142 | tcg_doc_hdr = Nothing, 143 | tcg_hpc = False, 144 | tcg_main = Nothing, 145 | tcg_safeInfer = infer_var, 146 | tcg_binds = emptyLHsBinds, 147 | tcg_sigs = emptyNameSet, 148 | tcg_imp_specs = [], 149 | tcg_rn_decls = maybe_rn_syntax emptyRnGroup, 150 | #if __GLASGOW_HASKELL__ <= 710 151 | tcg_used_rdrnames = used_rdr_var, 152 | #endif 153 | tcg_rn_imports = [], 154 | tcg_rn_exports = maybe_rn_syntax [], 155 | tcg_keep = keep_var, 156 | #if __GLASGOW_HASKELL__ > 710 157 | tcg_self_boot = NoSelfBoot, -- Assume there are no hsboot files 158 | tcg_used_gres = used_gre_var, 159 | tcg_th_remote_state = th_remote_state_var, 160 | tcg_tr_module = Nothing, 161 | #endif 162 | tcg_th_splice_used = th_splice_var 163 | } ; 164 | lcl_env = TcLclEnv { 165 | tcl_errs = errs_var, 166 | tcl_loc = realSrcLocSpan $ mkRealSrcLoc (fsLit "Top level") 1 1, 167 | tcl_ctxt = [], 168 | tcl_rdr = emptyLocalRdrEnv, 169 | tcl_th_ctxt = topStage, 170 | tcl_th_bndrs = emptyNameEnv, 171 | tcl_arrow_ctxt = NoArrowCtxt, 172 | tcl_env = emptyNameEnv, 173 | tcl_bndrs = [], 174 | tcl_tidy = emptyTidyEnv, 175 | tcl_tyvars = tvs_var, 176 | tcl_lie = lie_var, 177 | tcl_tclvl = topTcLevel 178 | } ; 179 | } ; 180 | 181 | -- OK, here's the business end! 182 | maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ 183 | do { r <- tryM do_this 184 | ; case r of 185 | Right res -> return (Just res) 186 | Left _ -> return Nothing } ; 187 | 188 | -- Check for unsolved constraints 189 | lie <- readIORef lie_var ; 190 | if isEmptyWC lie 191 | then return () 192 | else pprPanic "initTc: unsolved constraints" (ppr lie) ; 193 | 194 | -- Collect any error messages 195 | msgs <- readIORef errs_var ; 196 | 197 | let { final_res | errorsFound dflags msgs = Nothing 198 | | otherwise = maybe_res } ; 199 | 200 | return (msgs, final_res) 201 | } 202 | 203 | mk_type_env :: ModGuts -> TypeEnv 204 | -- copied from GHC.compileCore 205 | mk_type_env guts = typeEnvFromEntities (bindersOfBinds (mg_binds guts)) 206 | (mg_tcs guts) 207 | (mg_fam_insts guts) 208 | mk_field_env :: ModGuts -> RecFieldEnv 209 | -- TODO 210 | #if __GLASGOW_HASKELL__ > 710 211 | mk_field_env _ = emptyNameEnv 212 | #else 213 | mk_field_env _ = RecFields emptyNameEnv emptyNameSet 214 | #endif 215 | 216 | mk_dfun_n :: ModGuts -> OccSet 217 | -- TODO 218 | mk_dfun_n _ = emptyOccSet 219 | -------------------------------------------------------------------------------- /plugin/plugin.cabal: -------------------------------------------------------------------------------- 1 | name: assert-explainer 2 | cabal-version: >= 1.24 3 | build-type: Simple 4 | version: 1.0.0 5 | 6 | 7 | library 8 | default-language: Haskell2010 9 | build-depends: base 10 | , ghc 11 | , syb 12 | , containers 13 | , template-haskell 14 | , prettyprinter 15 | exposed-modules: AssertExplainer 16 | other-modules: Constraint 17 | ghc-options: -Wall 18 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fplugin=AssertExplainer #-} 2 | 3 | module Main where 4 | 5 | import Data.Char ( toUpper ) 6 | 7 | import Debug.Trace ( trace ) 8 | 9 | import AssertExplainer (assert) 10 | 11 | example1 = do 12 | assert True 13 | 14 | example2 = 15 | assert False 16 | 17 | example3 = 18 | assert ( length xs == 4 ) 19 | where xs = [ 1, 2, 3 ] 20 | 21 | example4 = 22 | assert ( z `elem` map toUpper ( "Hi," ++ " ZuriHac!" ) ) 23 | where z = 'z' 24 | 25 | main = do 26 | putStrLn "Example 1" 27 | example1 28 | 29 | example2 30 | 31 | example3 32 | 33 | example4 34 | -------------------------------------------------------------------------------- /test/test.cabal: -------------------------------------------------------------------------------- 1 | name: test 2 | cabal-version: >= 1.24 3 | build-type: Simple 4 | version: 1.0.0 5 | 6 | executable test 7 | default-language: Haskell2010 8 | build-depends: base, assert-explainer, prettyprinter 9 | main-is: Test.hs 10 | --------------------------------------------------------------------------------