{-# 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 (unless)
import Data.Foldable (asum)
import Data.Function (($), (.), const)
import Data.Functor ((<$>), (<$))
import Data.List (cycle, zipWith)
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import System.FilePath (FilePath, dropExtensions, takeBaseName, (</>), (<.>), (-<.>))
import System.IO (IO, IOMode(..), openFile)
import Test.Tasty (TestTree)
import Test.Tasty.Golden (goldenVsFileDiff)
import qualified System.Process as Process
import qualified Control.Exception as IO
import qualified System.Directory as IO
import qualified System.IO.Error as IO
import qualified Turtle

import Golden.Utils

ghcOpts :: [String]
ghcOpts = ghcFlags <>
  [ "-v0"
  , "-c"
  , "-ddump-splices"
  , "-dsuppress-uniques"
  , "-fforce-recomp"
  , "-fprint-explicit-kinds"
  , "-O0"
  --, "-i" <>rootDir</>"test"
  --, "-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
    (_, _, _, 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.waitForProcess pid
    normalizeSplice actualFile
  where
  actualFile = rootDir</>spliceFile-<.>"actual"<.>"txt"

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 = zipWith const (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