check-pvp-0.0.2: 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 (readPackageDescription, )
import Distribution.Simple.Utils (defaultPackageDesc)

import qualified Language.Haskell.Exts.Annotated.CPP as CPP
import qualified Language.Haskell.Exts.Annotated.Simplify as Simp
import qualified Language.Haskell.Exts.Annotated.Syntax as Syntax
import qualified Language.Haskell.Exts.Annotated as HSE
import qualified Language.Haskell.Exts as UnAnn
import Language.Haskell.Exts.Annotated.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"
      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.SrcSpan)
parse lang exts cppOpts file =
    return . fmap HSE.srcInfoSpan . 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 .
      readPackageDescription 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 (map Simp.sImportDecl imports)