tests/Golden/Parser.hs

   1 {-# LANGUAGE DataKinds #-} -- For using P.viewGrammar
   2 {-# LANGUAGE FlexibleContexts #-} -- For using P.Grammar Char
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE LambdaCase #-}
   5 {-# LANGUAGE TypeApplications #-}
   6 -- For TH splices
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE Rank2Types #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE UnboxedTuples #-}
  11 {-# OPTIONS_GHC -Wno-missing-signatures #-}
  12 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
  13 {-# OPTIONS_GHC -Wno-unused-matches #-}
  14 module Golden.Parser where
  15
  16 import Control.Monad (Monad(..))
  17 import Control.Monad.ST (stToIO)
  18 import Data.Function (($))
  19 import Data.Functor ((<$>))
  20 import Data.Int (Int)
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.String (String, IsString(..))
  23 import Data.Text (Text)
  24 import Data.Text.IO (readFile)
  25 import System.FilePath ((<.>), (</>), dropExtensions, takeBaseName)
  26 import System.IO.Unsafe (unsafePerformIO)
  27 import Test.Tasty
  28 import Test.Tasty.Golden
  29 import Text.Show (Show(..))
  30 import qualified Control.Exception as IO
  31 import qualified Data.List as List
  32 import qualified Data.Text as Text
  33 import qualified System.Directory as IO
  34 import qualified System.IO.Error as IO
  35 import qualified Language.Haskell.TH as TH
  36
  37 import qualified Symantic.Parser as SP
  38 import Golden.Utils
  39 import Golden.Splice
  40
  41 goldens :: TestTree
  42 goldens = testGroup "Parser" $
  43   (\f -> List.zipWith f parsers [1::Int ..]) $ \p g ->
  44   -- Collect the existing files: tests/Golden/Parser/G*.input.txt
  45   let parserDir = getGoldenDir $ "Parser/G"<>show g in
  46   let inputs =
  47         ((parserDir </>) <$>) $
  48         List.sort $
  49         List.filter (List.isSuffixOf ".input.txt") $
  50         unsafePerformIO $
  51           IO.catchIOError
  52             (IO.listDirectory parserDir)
  53             (\exn ->
  54               if IO.isDoesNotExistError exn
  55               then return []
  56               else IO.throwIO exn
  57             ) in
  58   testGroup ("G"<>show g) $ (<$> inputs) $ \inp ->
  59     goldenVsStringDiff (takeBaseName (dropExtensions inp)) goldenDiff
  60       (dropExtensions inp<.>"expected.txt") $ do
  61       input <- readFile inp
  62       let go r =
  63             stToIO r >>= \case
  64               SP.ResultDone a -> return $ fromString a
  65               SP.ResultError err -> return $ fromString $ show err
  66               SP.ResultPartial k ->
  67                 stToIO (k Text.empty) >>= \case
  68                   SP.ResultDone a -> return $ fromString a
  69                   SP.ResultError err -> return $ fromString $ show err
  70                   SP.ResultPartial{} -> return $ fromString "ResultPartial"
  71             in go (p input)
  72
  73 parsers :: [Text -> SP.Parsed Text String]
  74 parsers =
  75   [ p1, p2, p3, p4, p5, p6, p7, p8, p9
  76   , p10, p11, p12, p13, p14, p15, p16, p17, p18, p19
  77   , p20
  78   ]
  79
  80 p1 = $$(TH.Code $ TH.runIO s1)
  81 p2 = $$(TH.Code $ TH.runIO s2)
  82 p3 = $$(TH.Code $ TH.runIO s3)
  83 p4 = $$(TH.Code $ TH.runIO s4)
  84 p5 = $$(TH.Code $ TH.runIO s5)
  85 p6 = $$(TH.Code $ TH.runIO s6)
  86 p7 = $$(TH.Code $ TH.runIO s7)
  87 p8 = $$(TH.Code $ TH.runIO s8)
  88 p9 = $$(TH.Code $ TH.runIO s9)
  89 p10 = $$(TH.Code $ TH.runIO s10)
  90 p11 = $$(TH.Code $ TH.runIO s11)
  91 p12 = $$(TH.Code $ TH.runIO s12)
  92 p13 = $$(TH.Code $ TH.runIO s13)
  93 p14 = $$(TH.Code $ TH.runIO s14)
  94 p15 = $$(TH.Code $ TH.runIO s15)
  95 p16 = $$(TH.Code $ TH.runIO s16)
  96 p17 = $$(TH.Code $ TH.runIO s17)
  97 p18 = $$(TH.Code $ TH.runIO s18)
  98 p19 = $$(TH.Code $ TH.runIO s19)
  99 p20 = $$(TH.Code $ TH.runIO s20)