{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Common (
                RoundtripReport (..)
              , Report
              , ParseFailure(..)
              , ReportType(..)
              , roundTripTest
              , mkParsingTest
              , getModSummaryForFile

              , testList
              , testPrefix
              , Changer
              , genTest
              , noChange
              , mkDebugOutput
              , showErrorMessages
              , LibDir
              ) where



import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.GHC.ExactPrint.Preprocess
-- import Language.Haskell.GHC.ExactPrint.Types

import qualified Control.Monad.IO.Class as GHC
import qualified GHC           as GHC hiding (parseModule)
import qualified GHC.Data.Bag          as GHC
import qualified GHC.Driver.Session    as GHC
import qualified GHC.Utils.Error       as GHC
-- import qualified GHC.Utils.Outputable  as GHC
-- import qualified GHC.Hs.Dump           as GHC

import qualified GHC.LanguageExtensions as LangExt

-- import qualified Data.Map as Map

import Control.Monad
import Data.List hiding (find)

import System.Directory

-- import Test.Consistency

import Test.HUnit
import System.FilePath

-- import Debug.Trace
testPrefix :: FilePath
testPrefix = "." </> "tests" </> "examples"

testList :: String -> [Test] -> Test
testList s ts = TestLabel s (TestList ts)

-- ---------------------------------------------------------------------
-- Roundtrip machinery

type Report = Either ParseFailure RoundtripReport

data RoundtripReport =
  Report
   { debugTxt     :: String
   , status       :: ReportType
   , cppStatus    :: Maybe String -- Result of CPP if invoked
   -- , inconsistent :: Maybe [(AnnSpan, (GHC.AnnKeywordId, [AnnSpan]))]
   }

data ParseFailure = ParseFailure String

data ReportType =
   Success
 | RoundTripFailure deriving (Eq, Show)

{-
runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
runParser parser flags filename str = GHC.unP parser parseState
    where
      location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
      buffer = GHC.stringToStringBuffer str
      parseState = GHC.mkPState flags buffer location

parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs))
parseFile = runParser GHC.parseModule

mkApiAnns :: GHC.PState -> GHC.ApiAnns
mkApiAnns pstate = (Map.fromListWith (++) . GHC.annotations $ pstate
                   , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate)))

removeSpaces :: String -> String
removeSpaces = map (\case {'\160' -> ' '; s -> s})
-}

roundTripTest :: LibDir -> FilePath -> IO Report
roundTripTest libdir f = genTest libdir noChange f f


mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test
mkParsingTest tester dir fp =
  let basename       = testPrefix </> dir </> fp
      writeFailure   = writeFile (basename <.> "out")
      writeHsPP      = writeFile (basename <.> "hspp")
      -- writeIncons s  = writeFile (basename <.> "incons") (showGhc s)
  in
    TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id
                        <$> tester basename
                 writeFailure (debugTxt r)
                 -- forM_ (inconsistent r) writeIncons
                 forM_ (cppStatus r) writeHsPP
                 assertBool fp (status r == Success))


-- type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource))
-- First param is libdir
type Changer = LibDir -> (GHC.ParsedSource -> IO GHC.ParsedSource)

noChange :: Changer
noChange _libdir parsed = return parsed

genTest :: LibDir -> Changer -> FilePath -> FilePath -> IO Report
genTest libdir f origFile expectedFile  = do
      res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile
      expected <- GHC.liftIO $ readFileGhc expectedFile
      orig <- GHC.liftIO $ readFileGhc origFile
      -- let pristine = removeSpaces expected
      let pristine = expected

      case res of
        Left m -> return . Left $ ParseFailure (showErrorMessages m)
        Right (injectedComments, dflags, pmod)  -> do
          (printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments)
          let useCpp = GHC.xopt LangExt.Cpp dflags
              printed = trimPrinted printed'
              -- Clang cpp adds an extra newline character
              -- Do not remove this line!
              trimPrinted p = if useCpp
                                then unlines $ take (length (lines pristine)) (lines p)
                                else p
              debugTxt = mkDebugOutput origFile printed pristine pmod'
              -- consistency = checkConsistency apianns pmod
              -- inconsistent = if null consistency then Nothing else Just consistency
              status = if printed == pristine then Success else RoundTripFailure
              cppStatus = if useCpp then Just orig else Nothing
          return $ Right Report {..}


mkDebugOutput :: FilePath -> String -> String
              -> GHC.ParsedSource -> String
mkDebugOutput filename printed original parsed =
  intercalate sep [ printed
                 , filename
                 , "lengths:" ++ show (length printed,length original) ++ "\n"
                 -- , showAnnData anns 0 parsed
                 , showAst parsed
                 -- , showGhc anns
                ]
  where
    sep = "\n==============\n"



runRoundTrip :: LibDir
             -> Changer
             -> GHC.Located GHC.HsModule
             -> [GHC.LEpaComment]
             -> IO (String, GHC.ParsedSource)
runRoundTrip libdir f !parsedOrig cs = do
  let !parsedOrigWithComments = insertCppComments parsedOrig cs
  pmod <- f libdir parsedOrigWithComments
  let !printed = exactPrint pmod
  return (printed, pmod)

-- ---------------------------------------------------------------------`

canonicalizeGraph ::
  [GHC.ModSummary] -> IO [(Maybe (FilePath), GHC.ModSummary)]
canonicalizeGraph graph = do
  let mm = map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
      canon ((Just fp),m) = do
        fp' <- canonicalizePath fp
        return $ (Just fp',m)
      canon (Nothing,m)  = return (Nothing,m)

  mm' <- mapM canon mm

  return mm'

-- ---------------------------------------------------------------------

getModSummaryForFile :: (GHC.GhcMonad m) => FilePath -> m (Maybe GHC.ModSummary)
getModSummaryForFile fileName = do
  cfileName <- GHC.liftIO $ canonicalizePath fileName

  graph <- GHC.getModuleGraph
  cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph)

  let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph
  case mm of
   [] -> return Nothing
   fs -> return (Just (snd $ head fs))

-- ---------------------------------------------------------------------

showErrorMessages :: GHC.ErrorMessages -> String
showErrorMessages m = show $ GHC.bagToList m

-- ---------------------------------------------------------------------

-- instance GHC.Outputable GHC.ApiAnns where
--   ppr (GHC.ApiAnns items eof comments rogueComments)
--     = GHC.text "ApiAnns" GHC.<+> GHC.ppr items
--                          GHC.<+> GHC.ppr eof
--                          GHC.<+> GHC.ppr comments
--                          GHC.<+> GHC.ppr rogueComments

-- ---------------------------------------------------------------------