check-pvp-0.0.3: src/Advanced.hs

{-# LANGUAGE DeriveDataTypeable #-}
module Main where

import qualified CheckPVP

import Paths_check_pvp (version, )

import qualified Distribution.HaskellSuite.Compiler as Compiler
import Distribution.HaskellSuite.Packages (StandardDB, IsDBName, getDBName, )

import qualified Distribution.PackageDescription.Configuration as Config
import qualified Distribution.PackageDescription as P
import Distribution.PackageDescription.Parse (readGenericPackageDescription, )
import Distribution.Simple.Utils (defaultPackageDesc)
import Distribution.Version (mkVersion')

import qualified Language.Haskell.Exts.CPP as CPP
import qualified Language.Haskell.Exts.Syntax as Syntax
import qualified Language.Haskell.Exts as HSE
import qualified Language.Haskell.Exts as UnAnn
import Language.Haskell.Exts.CPP (CpphsOptions, defines, )
import Language.Haskell.Exts.SrcLoc (SrcLoc(SrcLoc), )
import Language.Haskell.Exts.Extension
          (Language(Haskell98), Extension, knownExtensions, knownLanguages, )

import Control.Exception (Exception, throwIO, )
import Data.Typeable (Typeable, )
import Data.Tagged (Tagged(Tagged), )
import Data.Foldable (forM_, )
import Data.Maybe (fromMaybe, )
import Text.Printf (printf, )


data PVPException = ParseError HSE.SrcLoc String
   deriving Typeable

instance Show PVPException where
   show (ParseError (SrcLoc file line col) msg) =
      printf "%s:%d:%d:\n  %s" file line col msg

instance Exception PVPException

fromParseResult :: HSE.ParseResult a -> IO a
fromParseResult (HSE.ParseOk x) = return x
fromParseResult (HSE.ParseFailed loc msg) = throwIO $ ParseError loc msg

main :: IO ()
main = Compiler.main theTool

data CheckPVPName = CheckPVPName

instance IsDBName CheckPVPName where
   getDBName = Tagged "check-pvp"

theTool :: Compiler.Simple (StandardDB CheckPVPName)
theTool =
   Compiler.simple
      "check-pvp"
      (mkVersion' version)
      knownLanguages
      knownExtensions
      compile
      []

fixCppOpts :: CpphsOptions -> CpphsOptions
fixCppOpts opts =
   opts {
      defines = ("__GLASGOW_HASKELL__", "763") : defines opts
   }

parse ::
   Language -> [Extension] -> CpphsOptions -> FilePath ->
   IO (HSE.Module HSE.SrcSpanInfo)
parse lang exts cppOpts file =
    return . fst
       =<< fromParseResult
       =<< CPP.parseFileWithCommentsAndCPP
              (fixCppOpts cppOpts) (mode lang exts file) file

mode :: Language -> [Extension] -> String -> UnAnn.ParseMode
mode lang exts file =
   UnAnn.defaultParseMode {
      UnAnn.parseFilename         = file,
      UnAnn.baseLanguage          = lang,
      UnAnn.extensions            = exts,
      UnAnn.ignoreLanguagePragmas = False,
      UnAnn.ignoreLinePragmas     = False
   }

compile :: Compiler.CompileFn
compile _buildDir mbLang exts cppOpts _pkgName _pkgdbs _deps files = do
   let lang = fromMaybe Haskell98 mbLang
       flags = CheckPVP.defaultFlags

   let verbosity = CheckPVP.flagVerbosity flags
   desc <-
      fmap Config.flattenPackageDescription .
      readGenericPackageDescription verbosity
       =<< defaultPackageDesc verbosity

   let classified = CheckPVP.classifyDependencies $ P.buildDepends desc
   mapM_ (CheckPVP.printUpperBoundDiagnostics flags) classified

   checkFlags <- CheckPVP.makeCheckFlags flags classified

   moduleSet <- mapM (parse lang exts cppOpts) files
   forM_ moduleSet $
         \(Syntax.Module _loc _head _pragma imports _decls) ->
      CheckPVP.checkImports checkFlags imports