test/Golden/Splice/Utils.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TypeApplications #-}
   3 module Golden.Splice.Utils where
   4
   5 -- Build_symantic_parser is auto-generated by Setup.hs
   6 import Build_symantic_parser (ghcPath, ghcFlags, rootDir)
   7 import Control.Applicative (Applicative(..))
   8 import Data.Foldable (asum)
   9 import Data.Function (($), (.), const)
  10 import Data.Functor ((<$>), (<$))
  11 import Data.List (cycle, zipWith)
  12 import Data.Maybe (Maybe(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.String (String, IsString(..))
  15 import Data.Text (Text)
  16 import System.FilePath (FilePath, (</>), (<.>), (-<.>))
  17 import System.IO (IO, IOMode(..), openFile)
  18 import System.Process (CreateProcess(..), StdStream(..), createProcess, proc, waitForProcess, callCommand)
  19 import Test.Tasty (TestTree)
  20 import Test.Tasty.Golden (goldenVsFileDiff)
  21 import qualified Turtle
  22 import Golden.Utils
  23
  24 ghcOpts :: [String]
  25 ghcOpts = ghcFlags <>
  26   [ "-v0"
  27   , "-c"
  28   , "-ddump-splices"
  29   , "-dsuppress-uniques"
  30   , "-fforce-recomp"
  31   , "-fprint-explicit-kinds"
  32   , "-O0"
  33   --, "-i" <>rootDir</>"test"
  34   --, "-XConstraintKinds"
  35   , "-XDataKinds"
  36   --, "-XDefaultSignatures"
  37   --, "-XEmptyCase"
  38   , "-XFlexibleContexts"
  39   , "-XFlexibleInstances"
  40   , "-XGADTs"
  41   --, "-XInstanceSigs"
  42   --, "-XKindSignatures"
  43   , "-XLambdaCase"
  44   , "-XMultiParamTypeClasses"
  45   --, "-XNoStarIsType"
  46   --, "-XPolyKinds"
  47   , "-XRankNTypes"
  48   , "-XScopedTypeVariables"
  49   --, "-XStandaloneDeriving"
  50   --, "-XStandaloneKindSignatures"
  51   , "-XTemplateHaskell"
  52   , "-XTypeApplications"
  53   , "-XTypeFamilies"
  54   , "-XTypeOperators"
  55   , "-XUnboxedTuples"
  56   --, "-XUndecidableInstances"
  57   ]
  58
  59 testSplice :: FilePath -> TestTree
  60 testSplice spliceFile =
  61   goldenVsFileDiff spliceFile goldenDiff
  62     (rootDir</>spliceFile-<.>"expected"<.>"txt")
  63     actualFile $ do
  64     h <- openFile actualFile WriteMode
  65     (_, _, _, pid) <- createProcess
  66       (proc ghcPath (spliceFile : ghcOpts))
  67       { std_out = UseHandle h
  68       , std_err = UseHandle h
  69       , cwd = Just rootDir }
  70     _ <- waitForProcess pid
  71     normalizeSplice actualFile
  72   where
  73   actualFile = rootDir</>spliceFile-<.>"actual"<.>"hs"
  74
  75 normalizeSplice :: FilePath -> IO ()
  76 normalizeSplice = Turtle.inplace pat . fromString
  77   where
  78   pat :: Turtle.Pattern Text
  79   pat = asum
  80     [ "(0,0)-(0,0)" <$ numPair <* "-" <* numPair
  81     , ":0:0:" <$ ":" <* d <* ":" <* d <* "-" <* d
  82     , ":0:0" <$ ":" <* d <* ":" <* d
  83     , fromString @Text . numPeriod <$> Turtle.lowerBounded 10 Turtle.digit
  84     , fromString @Text . ('%' <$) <$> Turtle.lowerBounded 10 punctSym
  85     -- Remove pretty-printed references to the symantic-parser package
  86     -- (e.g., turn `symantic-parser-2.4.1:Sing` into `Sing`)
  87     -- to make the output more stable.
  88     , "" <$ "symantic-parser-" <* verNum <* ":"
  89     ]
  90   verNum = d `Turtle.sepBy` Turtle.char '.'
  91   numPair = () <$ "(" <* d <* "," <* d <* ")"
  92   punctSym = Turtle.oneOf "!#$%&*+./>"
  93   numPeriod = zipWith const (cycle "0123456789876543210")
  94   d = Turtle.some Turtle.digit
  95
  96 cleanFiles :: IO ()
  97 cleanFiles = callCommand $ "rm -f " <> rootDir </> "test/Golden/Splice/*/*.{actual.hs,hi,o}"