{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Golden.Splice.Utils where

-- Build_symantic_parser is auto-generated by Setup.hs
import Build_symantic_parser (ghcPath, ghcFlags, rootDir)
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), unless, void)
import Data.Foldable (asum)
import Data.Function (($), (.), const, on)
import Data.Functor ((<$>), (<$))
import Data.Eq (Eq(..))
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Tuple (fst)
-- import System.Environment (getEnvironment)
import System.FilePath (FilePath, dropExtensions, takeBaseName, (</>), (<.>), (-<.>))
import System.IO (IO, IOMode(..), openFile, print)
import Test.Tasty (TestTree)
import Test.Tasty.Golden (goldenVsFileDiff, goldenVsStringDiff)
import Text.Show (Show(..))
import qualified Control.Exception as IO
import qualified Data.List as List
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.PprLib as TH
import qualified System.Directory as IO
import qualified System.IO.Error as IO
import qualified System.Process as Process
--import qualified Text.PrettyPrint as PP
import qualified Turtle

import Golden.Utils

import Debug.Trace

ghcOpts :: [String]
ghcOpts = traceShowId ghcFlags <>
  [ "-v0"
  , "-c"
  , "-ddump-splices"
  , "-dsuppress-uniques"
  --, "-static"
  --, "-dynamic"
  --, "-O", "-prof", "-fprof-auto-exported"
  --, "-osuf", "p_o", "-hisuf", "p_hi"
  -- , "-prof" --, "-fprof-auto"
  -- , "-eventlog", "-debug"
  -- , "-fexternal-interpreter", "-opti+RTS", "-opti-p", "-opti-L100", "-opti-ls", "-opti-xc"
  --, "-fhpc", "-hpcdir", "-opti/home/julm/work/sourcephile/haskell/symantic-parser/dist-newstyle/build/x86_64-linux/ghc-9.0.1/symantic-parser-0.1.0.20210201/hpc/vanilla/mix/symantic-parser-test"
  -- , "-opti-fhpc", "-opti-hpcdir", "-opti/home/julm/work/sourcephile/haskell/symantic-parser/dist-newstyle/build/x86_64-linux/ghc-9.0.1/symantic-parser-0.1.0.20210201/hpc/vanilla/mix/symantic-parser-test"
  , "-fforce-recomp"
  , "-fprint-explicit-kinds"
  , "-O0"
  --, "-XConstraintKinds"
  , "-XDataKinds"
  --, "-XDefaultSignatures"
  --, "-XEmptyCase"
  , "-XFlexibleContexts"
  , "-XFlexibleInstances"
  , "-XGADTs"
  --, "-XInstanceSigs"
  --, "-XKindSignatures"
  , "-XLambdaCase"
  , "-XMultiParamTypeClasses"
  --, "-XNoStarIsType"
  --, "-XPolyKinds"
  , "-XRankNTypes"
  , "-XScopedTypeVariables"
  --, "-XStandaloneDeriving"
  --, "-XStandaloneKindSignatures"
  , "-XTemplateHaskell"
  , "-XTypeApplications"
  , "-XTypeFamilies"
  , "-XTypeOperators"
  , "-XUnboxedTuples"
  --, "-XUndecidableInstances"
  ]

testSplice :: FilePath -> TestTree
testSplice spliceFile =
  goldenVsFileDiff (takeBaseName (dropExtensions spliceFile)) goldenDiff
    (rootDir</>spliceFile-<.>"expected"<.>"txt")
    actualFile $ do
    h <- openFile actualFile WriteMode
    --env <- getEnvironment
    (_, _, _, pid) <- Process.createProcess
      (Process.proc ghcPath (spliceFile : ghcOpts))
      { Process.std_out = Process.UseHandle h
      , Process.std_err = Process.UseHandle h
      , Process.cwd = Just rootDir
      {-
      , Process.env = Just $ traceShowId $
        List.deleteBy ((==) `on` fst) ("HPCTIXFILE", "") env
      -}
      }
    void $ Process.waitForProcess pid
    normalizeSplice actualFile
  where
  actualFile = rootDir</>spliceFile-<.>"actual"<.>"txt"

coverSplice :: IO (TH.TExp a) -> FilePath -> TestTree
coverSplice splice spliceFile =
  goldenVsStringDiff (takeBaseName (dropExtensions spliceFile)) goldenDiff
    (rootDir</>spliceFile) $ do
    --resetTHNameCounter
    tExp <- splice
    fromString <$> Process.readProcess "ormolu"
      [ "-o", "-XMagicHash"
      , "-o", "-XUnboxedTuples"
      , "-o", "-XBangPatterns"
      , "-o", "-XTypeApplications" ]
      (show (TH.ppr (TH.unType tExp)))
    {-
    return $ fromString $ PP.renderStyle PP.Style
      { PP.lineLength = 100
      , PP.ribbonsPerLine = 0.1
      , PP.mode = PP.PageMode
      } $ TH.to_HPJ_Doc $ TH.ppr $ TH.unType tExp
    -}

normalizeSplice :: FilePath -> IO ()
normalizeSplice = Turtle.inplace pat . fromString
  where
  pat :: Turtle.Pattern Text
  pat = asum
    [ "(0,0)-(0,0)" <$ numPair <* "-" <* numPair
    , ":0:0:" <$ ":" <* d <* ":" <* d <* "-" <* d
    , ":0:0" <$ ":" <* d <* ":" <* d
    , fromString @Text . numPeriod <$> Turtle.lowerBounded 10 Turtle.digit
    , fromString @Text . ('%' <$) <$> Turtle.lowerBounded 10 punctSym
    -- Remove pretty-printed references to the symantic-parser package
    -- (e.g., turn `symantic-parser-1.2.3:Catcher` into `Catcher`)
    -- to make the output more stable.
    , "" <$ "symantic-parser-" <* verNum <* ":"
    ]
  verNum = d `Turtle.sepBy` Turtle.char '.'
  numPair = () <$ "(" <* d <* "," <* d <* ")"
  punctSym = Turtle.oneOf "!#$%&*+./>"
  numPeriod = List.zipWith const (List.cycle "0123456789876543210")
  d = Turtle.some Turtle.digit

rmFile :: FilePath -> IO ()
rmFile path =
  IO.catchIOError (IO.removeFile path) $ \exn ->
    unless (IO.isDoesNotExistError exn) $
      IO.throwIO exn