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 (Monad(..), unless, void)
   9 import Data.Foldable (asum)
  10 import Data.Function (($), (.), const, on)
  11 import Data.Functor ((<$>), (<$))
  12 import Data.Eq (Eq(..))
  13 import Data.Maybe (Maybe(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String, IsString(..))
  16 import Data.Text (Text)
  17 import Data.Tuple (fst)
  18 -- import System.Environment (getEnvironment)
  19 import System.FilePath (FilePath, dropExtensions, takeBaseName, (</>), (<.>), (-<.>))
  20 import System.IO (IO, IOMode(..), openFile, print)
  21 import Test.Tasty (TestTree)
  22 import Test.Tasty.Golden (goldenVsFileDiff, goldenVsStringDiff)
  23 import Text.Show (Show(..))
  24 import qualified Control.Exception as IO
  25 import qualified Data.List as List
  26 import qualified Language.Haskell.TH as TH
  27 import qualified Language.Haskell.TH.Syntax as TH
  28 import qualified Language.Haskell.TH.PprLib as TH
  29 import qualified System.Directory as IO
  30 import qualified System.IO.Error as IO
  31 import qualified System.Process as Process
  32 --import qualified Text.PrettyPrint as PP
  33 import qualified Turtle
  34
  35 import Golden.Utils
  36
  37 import Debug.Trace
  38
  39 ghcOpts :: [String]
  40 ghcOpts = traceShowId ghcFlags <>
  41   [ "-v0"
  42   , "-c"
  43   , "-ddump-splices"
  44   , "-dsuppress-uniques"
  45   --, "-static"
  46   --, "-dynamic"
  47   --, "-O", "-prof", "-fprof-auto-exported"
  48   --, "-osuf", "p_o", "-hisuf", "p_hi"
  49   -- , "-prof" --, "-fprof-auto"
  50   -- , "-eventlog", "-debug"
  51   -- , "-fexternal-interpreter", "-opti+RTS", "-opti-p", "-opti-L100", "-opti-ls", "-opti-xc"
  52   --, "-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"
  53   -- , "-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"
  54   , "-fforce-recomp"
  55   , "-fprint-explicit-kinds"
  56   , "-O0"
  57   --, "-XConstraintKinds"
  58   , "-XDataKinds"
  59   --, "-XDefaultSignatures"
  60   --, "-XEmptyCase"
  61   , "-XFlexibleContexts"
  62   , "-XFlexibleInstances"
  63   , "-XGADTs"
  64   --, "-XInstanceSigs"
  65   --, "-XKindSignatures"
  66   , "-XLambdaCase"
  67   , "-XMultiParamTypeClasses"
  68   --, "-XNoStarIsType"
  69   --, "-XPolyKinds"
  70   , "-XRankNTypes"
  71   , "-XScopedTypeVariables"
  72   --, "-XStandaloneDeriving"
  73   --, "-XStandaloneKindSignatures"
  74   , "-XTemplateHaskell"
  75   , "-XTypeApplications"
  76   , "-XTypeFamilies"
  77   , "-XTypeOperators"
  78   , "-XUnboxedTuples"
  79   --, "-XUndecidableInstances"
  80   ]
  81
  82 testSplice :: FilePath -> TestTree
  83 testSplice spliceFile =
  84   goldenVsFileDiff (takeBaseName (dropExtensions spliceFile)) goldenDiff
  85     (rootDir</>spliceFile-<.>"expected"<.>"txt")
  86     actualFile $ do
  87     h <- openFile actualFile WriteMode
  88     --env <- getEnvironment
  89     (_, _, _, pid) <- Process.createProcess
  90       (Process.proc ghcPath (spliceFile : ghcOpts))
  91       { Process.std_out = Process.UseHandle h
  92       , Process.std_err = Process.UseHandle h
  93       , Process.cwd = Just rootDir
  94       {-
  95       , Process.env = Just $ traceShowId $
  96         List.deleteBy ((==) `on` fst) ("HPCTIXFILE", "") env
  97       -}
  98       }
  99     void $ Process.waitForProcess pid
 100     normalizeSplice actualFile
 101   where
 102   actualFile = rootDir</>spliceFile-<.>"actual"<.>"txt"
 103
 104 coverSplice :: IO (TH.TExp a) -> FilePath -> TestTree
 105 coverSplice splice spliceFile =
 106   goldenVsStringDiff (takeBaseName (dropExtensions spliceFile)) goldenDiff
 107     (rootDir</>spliceFile) $ do
 108     --resetTHNameCounter
 109     tExp <- splice
 110     fromString <$> Process.readProcess "ormolu"
 111       [ "-o", "-XMagicHash"
 112       , "-o", "-XUnboxedTuples"
 113       , "-o", "-XBangPatterns"
 114       , "-o", "-XTypeApplications" ]
 115       (show (TH.ppr (TH.unType tExp)))
 116     {-
 117     return $ fromString $ PP.renderStyle PP.Style
 118       { PP.lineLength = 100
 119       , PP.ribbonsPerLine = 0.1
 120       , PP.mode = PP.PageMode
 121       } $ TH.to_HPJ_Doc $ TH.ppr $ TH.unType tExp
 122     -}
 123
 124 normalizeSplice :: FilePath -> IO ()
 125 normalizeSplice = Turtle.inplace pat . fromString
 126   where
 127   pat :: Turtle.Pattern Text
 128   pat = asum
 129     [ "(0,0)-(0,0)" <$ numPair <* "-" <* numPair
 130     , ":0:0:" <$ ":" <* d <* ":" <* d <* "-" <* d
 131     , ":0:0" <$ ":" <* d <* ":" <* d
 132     , fromString @Text . numPeriod <$> Turtle.lowerBounded 10 Turtle.digit
 133     , fromString @Text . ('%' <$) <$> Turtle.lowerBounded 10 punctSym
 134     -- Remove pretty-printed references to the symantic-parser package
 135     -- (e.g., turn `symantic-parser-1.2.3:Catcher` into `Catcher`)
 136     -- to make the output more stable.
 137     , "" <$ "symantic-parser-" <* verNum <* ":"
 138     ]
 139   verNum = d `Turtle.sepBy` Turtle.char '.'
 140   numPair = () <$ "(" <* d <* "," <* d <* ")"
 141   punctSym = Turtle.oneOf "!#$%&*+./>"
 142   numPeriod = List.zipWith const (List.cycle "0123456789876543210")
 143   d = Turtle.some Turtle.digit
 144
 145 rmFile :: FilePath -> IO ()
 146 rmFile path =
 147   IO.catchIOError (IO.removeFile path) $ \exn ->
 148     unless (IO.isDoesNotExistError exn) $
 149       IO.throwIO exn