ghc-srcspan-plugin 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+100/−36 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ghc-srcspan-plugin.cabal +3/−2
• src/GHC/Plugins/ErrorLoc.hs +70/−0
• src/GHC/Plugins/SrcSpan.hs +27/−34

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                ghc-srcspan-plugin-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Generic GHC Plugin for annotating Haskell code with source                      location data. description:         This package provides a generic Core-to-Core pass for@@ -28,7 +28,8 @@   location: https://github.com/GaloisInc/ghc-srcspan-plugin  library-  exposed-modules:     GHC.Plugins.SrcSpan+  exposed-modules:     GHC.Plugins.SrcSpan,+                       GHC.Plugins.ErrorLoc   build-depends:       base >= 4.7 && < 5,                        ghc >= 7.8,                        array,

@@ -0,0 +1,70 @@+module GHC.Plugins.ErrorLoc+  (plugin, errorAt, undefinedAt, fromJustAt)+  where++import DynamicLoading+import GhcPlugins+import GHC.Plugins.SrcSpan++plugin :: Plugin+plugin = defaultPlugin { installCoreToDos = install }++install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install opts todos = do+  reinitializeGlobals++  hsc_env <- getHscEnv+  Just errorAtName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env+                               (mkModuleName "GHC.Plugins.ErrorLoc")+                               (mkVarUnqual $ fsLit "errorAt")+  errorAtVar <- lookupId errorAtName++  Just undefAtName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env+                               (mkModuleName "GHC.Plugins.ErrorLoc")+                               (mkVarUnqual $ fsLit "undefinedAt")+  undefAtVar <- lookupId undefAtName++  Just fmjstName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env+                             (mkModuleName "Data.Maybe")+                             (mkVarUnqual $ fsLit "fromJust")+  fmjstVar <- lookupId fmjstName++  Just fmjstAtName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env+                               (mkModuleName "GHC.Plugins.ErrorLoc")+                               (mkVarUnqual $ fsLit "fromJustAt")+  fmjstAtVar <- lookupId fmjstAtName++  let subst = [ (eRROR_ID, errorAtVar), (uNDEFINED_ID, undefAtVar)+              , (fmjstVar, fmjstAtVar)+              ]++  let annotate = mkErrorAt subst++  let mypass = CoreDoPluginPass "Add Locations to `error` calls"+             $ mkPass annotate ("kill-foreign-stubs" `elem` opts)+  return $ mypass : todos++isErrorVar :: [(Var,Var)] -> Var -> Maybe Var+isErrorVar subst v = lookup v subst++mkErrorAt :: [(Var,Var)] -> SrcSpan -> CoreExpr -> CoreM CoreExpr+mkErrorAt subst loc (App (Var v) (Type t))+  | Just v' <- isErrorVar subst v = do+      df <- getDynFlags+      locStr <- mkStringExpr $ showPpr df loc+      return $ mkCoreApps (Var v') [ Type t, locStr ]+mkErrorAt _ _ expr = return expr+++errorAt :: String -> String -> a+errorAt loc msg = error (loc ++ ": " ++ msg)+{-# INLINE errorAt #-}++undefinedAt :: String -> a+undefinedAt loc = errorAt loc "Prelude.undefined"+{-# INLINE undefinedAt #-}++fromJustAt :: String -> Maybe a -> a+fromJustAt loc Nothing  = errorAt loc "Maybe.fromJust: Nothing"+fromJustAt _   (Just x) = x+{-# INLINE fromJustAt #-}

@@ -4,9 +4,8 @@  -- | This module provides a generic Core-to-Core pass for annotating Haskell -- expressions with the original source locations. You can use it to build a GHC--- Plugin tailored to your own library by providing a predicate to select--- interesting expressions for annotation and a function to annotate the--- expressions.+-- Plugin tailored to your own library by providing a predicate a function to+-- annotate interesting expressions. -- -- Example usage: --@@ -23,8 +22,7 @@ -- >   reinitializeGlobals -- >   return $ mypass : todos -- >   where--- >   mypass = CoreDoPluginPass "Add Locations" $ mkPass isInteresting annotate False--- >   isInteresting expr = ...+-- >   mypass = CoreDoPluginPass "Add Locations" $ mkPass annotate False -- >   annotate expr = ... -- -- You will need to coax GHC into adding the source information to the Core via@@ -53,21 +51,19 @@ import           Trace.Hpc.Util  --- | Given a way of identifying "interesting" 'CoreExpr's and annotating them--- with 'SrcSpan's, construct a Core-to-Core pass that traverses all of the--- 'CoreBind's and annotates the interesting ones.-mkPass :: (CoreExpr -> CoreM Bool)-          -- ^ Should we annotate this 'CoreExpr'?-       -> (SrcSpan -> CoreExpr -> CoreM CoreExpr)-          -- ^ Annotate the 'CoreExpr' with the 'SrcSpan'.+-- | Given a way of annotating "interesting" 'CoreExpr's with 'SrcSpan's,+-- construct a Core-to-Core pass that traverses all of the 'CoreBind's and+-- annotates the interesting ones.+mkPass :: (SrcSpan -> CoreExpr -> CoreM CoreExpr)+          -- ^ Annotate the 'CoreExpr' with the 'SrcSpan' if it's interesting.        -> Bool           -- ^ Should we remove the @hpc@ hooks from the resulting binary?        -> ModGuts -> CoreM ModGuts-mkPass isInteresting annotate killForeignStubs guts@(ModGuts {..}) = do+mkPass annotate killForeignStubs guts@(ModGuts {..}) = do   df    <- getDynFlags   mkLoc <- liftIO $ getSpans df guts -  binds <- mapM (addLocationsBind mkLoc isInteresting annotate) mg_binds+  binds <- mapM (addLocationsBind mkLoc annotate) mg_binds    let stubs = if killForeignStubs                  then NoStubs@@ -102,40 +98,37 @@   addLocationsBind :: (Tickish Var -> SrcSpan)-                 -> (CoreExpr -> CoreM Bool)                   -> (SrcSpan -> CoreExpr -> CoreM CoreExpr)                   -> CoreBind -> CoreM CoreBind-addLocationsBind getSpan isInteresting annotate bndr = case bndr of-  NonRec b expr -> NonRec b `liftM` addLocationsExpr getSpan annotate isInteresting expr-  Rec binds     -> Rec `liftM` forM binds (secondM $ addLocationsExpr getSpan annotate isInteresting)+addLocationsBind getSpan annotate bndr = case bndr of+  NonRec b expr -> NonRec b `liftM` addLocationsExpr getSpan annotate expr+  Rec binds     -> Rec `liftM` forM binds (secondM $ addLocationsExpr getSpan annotate)   addLocationsExpr :: (Tickish Var -> SrcSpan)                  -> (SrcSpan -> CoreExpr -> CoreM CoreExpr)-                 -> (CoreExpr -> CoreM Bool)                  -> CoreExpr -> CoreM CoreExpr-addLocationsExpr getSpan annotate isInteresting = go noSrcSpan+addLocationsExpr getSpan annotate = go noSrcSpan   where   go ss (Tick t expr)      | isGoodSrcSpan (getSpan t)-    = go (getSpan t) expr+    = liftM (Tick t) (go (getSpan t) expr)     | otherwise-    = go ss expr-  go ss e@(App expr arg) -    = do b <- isInteresting e-         let rest = liftM2 App (go ss expr) (go ss arg)-         if b-           then annotate ss =<< rest-           else rest-  go ss (Lam x expr)+    = liftM (Tick t) (go ss expr)+  go ss e+    = annotate ss =<< to ss e++  to ss (App f e)+    = liftM2 App (go ss f) (go ss e)+  to ss (Lam x expr)     = liftM (Lam x) (go ss expr)-  go ss (Let bndr expr)-    = liftM2 Let (addLocationsBind getSpan isInteresting annotate bndr) (go ss expr)-  go ss (Case expr x t alts)+  to ss (Let bndr expr)+    = liftM2 Let (addLocationsBind getSpan annotate bndr) (go ss expr)+  to ss (Case expr x t alts)     = liftM2 (\e as -> Case e x t as) (go ss expr) (mapM (addLocationsAlt ss) alts)-  go ss (Cast expr c)+  to ss (Cast expr c)     = liftM (`Cast` c) (go ss expr)-  go _  expr+  to _  expr     = return expr    addLocationsAlt ss (c, xs, expr)