prof2pretty-0.1.0.0: src/sccpragmabomb.hs

module Main (main) where

import Language.Haskell.Exts.Annotated
  ( Module
  , Exp(SCCPragma, Paren)
  , SrcSpanInfo
  , srcInfoSpan
  , SrcSpan(..)
  , fromParseResult
  , parseFileContentsWithMode
  , defaultParseMode
  , parseFilename
  , ann
  , prettyPrintWithMode
  , defaultMode
  , linePragmas
  )
import Data.Generics.Uniplate.Data (transformBi)
import Control.Exception (handle, SomeException(..))
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)
import Text.Encoding.Z (zEncodeString)

sccPragmaBomb :: String -> Module SrcSpanInfo -> Module SrcSpanInfo
sccPragmaBomb s = transformBi (addSCC s)

addSCC :: String -> Exp SrcSpanInfo -> Exp SrcSpanInfo
addSCC s e =
  let f = stripSCC e
      a = ann f
  in  Paren a (SCCPragma a (sccFromSrcSpan s (srcInfoSpan a)) f)

stripSCC :: Exp SrcSpanInfo -> Exp SrcSpanInfo
stripSCC (SCCPragma _ _ e) = e
stripSCC e = e

sccFromSrcSpan :: String -> SrcSpan -> String
sccFromSrcSpan s (SrcSpan
    { srcSpanStartLine = l0
    , srcSpanStartColumn = c0
    , srcSpanEndLine = l1
    , srcSpanEndColumn = c1
    }) = zEncodeString s ++ concatMap (('-':) . show) [l0,c0,l1,c1]

parse :: String -> String -> Module SrcSpanInfo
parse name = fromParseResult . parseFileContentsWithMode defaultParseMode{ parseFilename = name }

main :: IO ()
main = handle (\(SomeException e) -> hPutStrLn stderr ("sccpragmabomb: " ++ show e) >> exitFailure) $ do
  [originalFile, sourceFile, destinationFile] <- getArgs
  writeFile destinationFile . prettyPrintWithMode defaultMode{ linePragmas = True } . sccPragmaBomb originalFile . parse originalFile =<< readFile sourceFile