{-# 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 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, (</>), (<.>), (-<.>))
import System.IO (IO, IOMode(..), openFile)
import System.Process (CreateProcess(..), StdStream(..), createProcess, proc, waitForProcess, callCommand)
import Test.Tasty (TestTree)
import Test.Tasty.Golden (goldenVsFileDiff)
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 spliceFile goldenDiff
    (rootDir</>spliceFile-<.>"expected"<.>"txt")
    actualFile $ do
    h <- openFile actualFile WriteMode
    (_, _, _, pid) <- createProcess
      (proc ghcPath (spliceFile : ghcOpts))
      { std_out = UseHandle h
      , std_err = UseHandle h
      , cwd = Just rootDir }
    _ <- waitForProcess pid
    normalizeSplice actualFile
  where
  actualFile = rootDir</>spliceFile-<.>"actual"<.>"hs"

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-2.4.1:Sing` into `Sing`)
    -- 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

cleanFiles :: IO ()
cleanFiles = callCommand $ "rm -f " <> rootDir </> "test/Golden/Splice/*/*.{actual.hs,hi,o}"