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