line_pragma_plugin.hs

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE BangPatterns        #-}
{-# 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           GHC.Driver.Plugins
#else
import           GhcPlugins
#endif
                            ( CommandLineOption
                            , Plugin (..)
                            , RealSrcLoc(..), RealSrcSpan(..)
                            , GenLocated(..), SrcSpan(..)
                            , srcLocFile, srcLocLine, srcLocCol, mkRealSrcSpan, mkRealSrcLoc
                            , mkFastString, realSrcSpanStart, realSrcSpanEnd
                            , FastString
                            )
#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)
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'
       \args summary result@GhcPlugins.ParsedResult { GhcPlugins.parsedResultModule } ->
                     result <$ ghcLinePragmaPlugin args summary parsedResultModule,
#else
        ghcLinePragmaPlugin,
#endif
{-
#if   __GLASGOW_HASKELL__ >= 902
      driverPlugin       = ghcTagsDriverPlugin,
#else
      dynflagsPlugin     = ghcTagsDynflagsPlugin,
#endif
-}
      pluginRecompile    = GhcPlugins.purePlugin
   }


ghcLinePragmaPlugin :: [CommandLineOption]
                    -> ModSummary
                    -> HsParsedModule
                    -> Hsc HsParsedModule
ghcLinePragmaPlugin options
                    moduleSummary@ModSummary {ms_mod, ms_hspp_opts = dynFlags}
                    hsParsedModule =
    pure $! hsParsedModule
          { hpm_module = transformBi changeSrcSpan (hpm_module hsParsedModule)}
  where
    lineMapping :: M.Map FastString FastString
    lineMapping =
        let ps = T.splitOn "," (T.pack (head options))
            pairs = goPairs ps
        in {- trace (show pairs) $ -} M.fromList pairs

    goPairs (a:b:rest) = (mkFastString (T.unpack a), mkFastString (T.unpack b)) : goPairs rest
    goPairs _          = []
    
    changeSrcSpan :: SrcSpan -> SrcSpan
    changeSrcSpan ss = case ss of
      UnhelpfulSpan _ -> ss
      RealSrcSpan rss ->
        let a = realSrcSpanStart rss
            b = realSrcSpanEnd rss

        in RealSrcSpan $! mkRealSrcSpan (changeSrcLoc a) (changeSrcLoc b)
    changeSrcLoc :: RealSrcLoc -> RealSrcLoc
    changeSrcLoc sl =
        let oldF = srcLocFile sl
            newF = fromMaybe oldF (M.lookup oldF lineMapping)
        in {- trace (show oldF) $ -} mkRealSrcLoc newF (srcLocLine sl) (srcLocCol sl)

plugin.cabal

cabal-version:       2.4

name:                haskell-line-pragma-plugin
version:             0.1.0.0
license:             NONE
author:              Robin Palotai
maintainer:          robinp@treetide.com

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