Skip to content

Instantly share code, notes, and snippets.

@robinp

robinp/line_pragma_plugin.hs

Last active November 9, 2025 08:53
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save robinp/dea4898253baf2ef8d9089ca1b4f2539 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save robinp/dea4898253baf2ef8d9089ca1b4f2539 to your computer and use it in GitHub Desktop.
Download ZIP
Cover the error messages - now all output location are converted with GHC 9.
Raw
line_pragma_plugin.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wwarn #-}
module Plugin.LinePragma ( plugin ) where
{-
The plugin replaces the locations in HsParsedModule according to the
linemap passed as plugin option.
The linemap is a single string, where paths are separated by commas.
Pairs of paths are interpreted as (old module-relative source, absolute path to point to).
In effect, this achieves the same as a whole-file LINE pragma starting from
line 1, but doesn't need CPP or other file mangling. So can work with
symlinked original sources.
See https://gitlab.haskell.org/ghc/ghc/-/issues/23917.
Usage: pass to GHC (or cabal's ghc-options, after adding this plugin's cabal
package to build-depends):
-fplugin=Plugin.LinePragma -fplugin-opt=Plugin.LinePragma:src1,retargeted1,src2,retargeted2,...
Note: based on ghc-tags-plugin. Left imports as-is, only added as needed.
Tested with GHC 8.10.7. Adjustments likely needed for GHC 9.
-}
import Control.Exception
import Control.Monad (when)
#if __GLASGOW_HASKELL__ >= 906
-- import Control.Monad.State.Strict
#else
import Control.Monad.State.Strict hiding (when, void)
#endif
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Builder as BB
import Data.Functor (void)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Functor.Identity (Identity (..))
import Data.List (sortBy)
import Data.Either (partitionEithers, rights)
import Data.Foldable (traverse_)
import Data.Maybe (mapMaybe)
#if __GLASGOW_HASKELL__ > 906
import System.Directory.OsPath
#else
import System.Directory
#endif
import qualified System.FilePath as FilePath
import System.IO
import Options.Applicative.Types (ParserFailure (..))
#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Data.Strict as Strict
import GHC.Driver.Plugins
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Data.FastString
#else
import GhcPlugins
( CommandLineOption
, Plugin (..)
, RealSrcLoc(..), RealSrcSpan(..)
, GenLocated(..), SrcSpan(..)
, srcLocFile, srcLocLine, srcLocCol, mkRealSrcSpan, mkRealSrcLoc
, mkFastString, realSrcSpanStart, realSrcSpanEnd
, FastString
)
#endif
#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Driver.Plugins as GhcPlugins
#if __GLASGOW_HASKELL__ >= 902
import GHC.Driver.Env ( Hsc
, HscEnv (..)
)
import GHC.Hs (HsParsedModule (..))
import GHC.Unit.Module.ModSummary
(ModSummary (..))
import GHC.Types.Meta ( MetaHook
, MetaRequest (..)
, MetaResult
, metaRequestAW
, metaRequestD
, metaRequestE
, metaRequestP
, metaRequestT
)
#else
import GHC.Driver.Types ( Hsc
, HsParsedModule (..)
, ModSummary (..)
, MetaHook
, MetaRequest (..)
, MetaResult
, metaRequestAW
, metaRequestD
, metaRequestE
, metaRequestP
, metaRequestT
)
#endif
import GHC.Driver.Hooks (Hooks (..))
import GHC.Unit.Types (Module)
import GHC.Unit.Module.Location (ModLocation (..))
import GHC.Tc.Types (TcM)
import GHC.Tc.Gen.Splice (defaultRunMeta)
import GHC.Types.SrcLoc (Located)
import qualified GHC.Types.SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile)
#else
import qualified GhcPlugins
import GhcPlugins ( Hsc
, HsParsedModule (..)
, Located
, Module
, ModLocation (..)
, ModSummary (..)
#if __GLASGOW_HASKELL__ >= 810
, MetaHook
, MetaRequest (..)
, MetaResult
, metaRequestAW
, metaRequestD
, metaRequestE
, metaRequestP
, metaRequestT
#endif
)
import qualified SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile)
#endif
#if __GLASGOW_HASKELL__ >= 902
import GHC.Driver.Session (DynFlags)
#elif __GLASGOW_HASKELL__ >= 900
import GHC.Driver.Session (DynFlags (DynFlags, hooks))
#else
import DynFlags (DynFlags (DynFlags, hooks))
#endif
#if __GLASGOW_HASKELL__ >= 900
import GHC.Hs (GhcPs, GhcTc, HsModule (..), LHsDecl, LHsExpr)
#else
import GHC.Hs (GhcPs, GhcTc, HsModule (..), LHsDecl, LHsExpr)
import TcSplice
import TcRnMonad
import Hooks
#endif
#if __GLASGOW_HASKELL__ >= 900
import GHC.Utils.Outputable (($+$), ($$))
import qualified GHC.Utils.Outputable as Out
import qualified GHC.Utils.Ppr.Colour as PprColour
#else
import Outputable (($+$), ($$))
import qualified Outputable as Out
import qualified PprColour
#endif
#if __GLASGOW_HASKELL__ >= 900
import GHC.Data.FastString (bytesFS)
#else
import FastString (bytesFS)
#endif
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Generics.Uniplate.Data (transformBi, Biplate)
import qualified Data.Text as T
--import Debug.Trace
#if __GLASGOW_HASKELL__ >= 906
type GhcPsModule = HsModule GhcPs
#elif __GLASGOW_HASKELL__ >= 900
type GhcPsModule = HsModule
#else
type GhcPsModule = HsModule GhcPs
#endif
plugin :: Plugin
plugin = GhcPlugins.defaultPlugin {
parsedResultAction =
#if __GLASGOW_HASKELL__ >= 904
-- TODO: add warnings / errors to 'ParsedResult'.. but see below
\args summary result@pres -> do -- GhcPlugins.ParsedResult { GhcPlugins.parsedResultModule } -> do
let pmod = GhcPlugins.parsedResultModule pres
-- there are some errors like "Illegal symbol ‘forall’ in type" that (without better guess) resides in
-- the messages and currently is not translated.
-- Indeed it seems PsErrExplicitForall is what prints that.... ah the MsgEnvelope in Messages has the SrcSpan.
let plugMessages =
let plugMsgEnvelope me = me
{ errMsgSpan = ghcLinePragmaPlugin args (errMsgSpan me)
}
in mkMessages . foldMap (unitBag . plugMsgEnvelope) . getMessages
let msgs = GhcPlugins.parsedResultMessages pres
let msgs1 = PsMessages
{ psWarnings = plugMessages (psWarnings msgs)
, psErrors = plugMessages (psErrors msgs)
}
--
-- Invoking for RealSrcSpan directly in case there are raw ones.. not sure.
let m1 = ghcLinePragmaPlugin2 args (ghcLinePragmaPlugin args (hpm_module pmod))
pure $! result { parsedResultModule = pmod { hpm_module = m1 }, parsedResultMessages = msgs1 }
#else
ghcLinePragmaPlugin,
#endif
{-
#if __GLASGOW_HASKELL__ >= 902
driverPlugin = ghcTagsDriverPlugin,
#else
dynflagsPlugin = ghcTagsDynflagsPlugin,
#endif
-}
, pluginRecompile = GhcPlugins.purePlugin
}
#if __GLASGOW_HASKELL__ >= 900
type Ordable a = NonDetFastString
ordable :: FastString -> Ordable a
ordable = NonDetFastString
#else
type Ordable a = a
ordable :: FastString -> Ordable a
ordable = id
#endif
trace :: a -> b -> b
trace = const id
ghcLinePragmaPlugin :: (Biplate on SrcSpan) => [CommandLineOption]
-> on
-> on
ghcLinePragmaPlugin options a =
transformBi changeSrcSpan a
where
lineMapping :: M.Map (Ordable FastString) FastString
lineMapping =
let ps = T.splitOn "," (T.pack (head options))
pairs = goPairs ps
in trace (show ("pairs"::[Char], pairs)) $ M.fromList pairs
goPairs (a:b:rest) = (mkFastStringNonDet (T.unpack a), mkFastString (T.unpack b)) : goPairs rest
goPairs _ = []
--
mkFastStringNonDet = ordable . mkFastString
-- NOTE(RealSrcSpan): very weird. If we change to operate on RealSrcSpan (and context too), it compiles and runs,
-- but doesn't replace. Or maybe replaces, but leaving the buffer around as non-Nothing has priority? No, removing
-- touching the buffer makes no difference. Ah, SrcSpan's Data instance is dummy, with the note "Don't traverse".
changeSrcSpan :: SrcSpan -> SrcSpan
changeSrcSpan ss = case ss of
UnhelpfulSpan _ -> ss
RealSrcSpan rss x ->
let a = realSrcSpanStart rss
b = realSrcSpanEnd rss
in RealSrcSpan (mkRealSrcSpan (changeSrcLoc a) (changeSrcLoc b)) x
changeSrcLoc :: RealSrcLoc -> RealSrcLoc
changeSrcLoc sl =
let oldF = srcLocFile sl
newF = fromMaybe oldF (M.lookup (ordable oldF) lineMapping)
in trace (show ("oldF"::[Char], oldF, newF)) $ mkRealSrcLoc newF (srcLocLine sl) (srcLocCol sl)
ghcLinePragmaPlugin2 :: (Biplate on RealSrcSpan) => [CommandLineOption]
-> on
-> on
ghcLinePragmaPlugin2 options a =
transformBi changeSrcSpan a
where
lineMapping :: M.Map (Ordable FastString) FastString
lineMapping =
let ps = T.splitOn "," (T.pack (head options))
pairs = goPairs ps
in trace (show ("pairs"::[Char], pairs)) $ M.fromList pairs
goPairs (a:b:rest) = (mkFastStringNonDet (T.unpack a), mkFastString (T.unpack b)) : goPairs rest
goPairs _ = []
--
mkFastStringNonDet = ordable . mkFastString
changeSrcSpan :: RealSrcSpan -> RealSrcSpan
changeSrcSpan rss =
let a = realSrcSpanStart rss
b = realSrcSpanEnd rss
in mkRealSrcSpan (changeSrcLoc a) (changeSrcLoc b)
changeSrcLoc :: RealSrcLoc -> RealSrcLoc
changeSrcLoc sl =
let oldF = srcLocFile sl
newF = fromMaybe oldF (M.lookup (ordable oldF) lineMapping)
in trace (show ("oldF"::[Char], oldF, newF)) $ mkRealSrcLoc newF (srcLocLine sl) (srcLocCol sl)
Raw
plugin.cabal
cabal-version: 2.4
name: haskell-line-pragma-plugin
version: 0.1.0.0
license: NONE
author: Robin Palotai
maintainer: [email protected]
library
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
exposed-modules: Plugin.LinePragma
build-depends: base, bytestring, containers, directory, filepath, text, ghc, optparse-applicative, mtl, uniplate
-- hs-source-dirs:
default-language: Haskell2010
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment